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I. INTRODUCTION 



A. ADA-BASED SOFTWARE TOOLS 

As the Department of Defense’s commitment to the Ada language is firm, 
there is considerable interest in the development of Ada-based, automated 
software tools. The purpose of these tools is to increase the productivity and 
efficiency of software engineering efforts. Ada-based, automated metric tools 
have been successfully implemented at the Naval Postgraduate School in 
response to this need and at the request of Naval Weapons Center, China 
Lake; specifically, Neider and Fairbank’s implementation of the Halstead 
Length Metric in a thesis entitled "AdaMeasure” [Ref. 1], and Herzig’s 
extension of "AdaMeasure” to include the Sallie Henry and Dennis Kafura 
Complexity Flow Metric [Ref. 2]. 

Rather than rely on a specific metric implementation, the design of 
"AdaMeasure” incorporates a general top-down, recursive descent parser to 
collect the desired metric information. This parser relies on the premise that 
the input code has been correctly compiled before being analyzed for the 
desired metric data. This assumption allows the parser to utilize a modified 
Ada grammar which reduces the size and complexity of the parser while 
retaining the capability to parse an input file in enough detail to collect 
meaningful and relevant metric data. [Ref l:p. 28] 
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B. ANALYSIS OF REAL-TIME EMBEDDED SYSTEMS 

Of the available methods for performing software analysis, Leveson and 
Stolzy [Ref. 3J advocate the use of Petri nets as the most viable method for 
conducting a systems approach to software analysis. They argue that a 
systems approach is required since real-time embedded software seldom 
works "in a vacuum”. The choice of Petri nets as a desirable method for 
analysis is predicated on the ability of Petri nets to model hardware, software, 
and human behavior using the same language. An added advantage is that 
timing information can be incorporated into the Petri net model for analysis of 
real-time embedded systems. Leveson and Stolzy have proposed a Petri net 
based software analysis methodology that relies on deriving the untimed 
reachability graph of the system Petri net model in order to determine the 
timing constraints and properties of the final real-time imbedded system. 
Although principally concerned with software safety analysis, the analysis 
approach demonstrated by Leveson and Stolzy may be used to deduce other 
properties of a real-time embedded system. [Ref. 3] 

Shatz and Cheng [Ref. 41 were the first to describe an automated, Petri 
net based method for static analysis of Ada programs. Their analysis 
approach consisted of the following three steps / subsystems as illustrated in 
Figure 1.1: 

1. Translation of the source program into a Petri net model. 

2. Analysis of the Petri net model. 

3. Interpretation of the Petri net properties so as to derive properties of 
the source program. [Ref. 4:p. 378J 
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The Front End Translator Subsystem utilized a multi-pass translation 
algorithm and a translation table that stored Petri net equivalent templates 
of Ada structures of interest. As Shatz and Cheng were specifically concerned 
with distributed programs, their translation scheme concentrated on tasks 
and their synchronization and communication mechanisms. They did not 
explicitly consider Ada packages and function program units. These Petri net 
templates of Ada structures were uniquely labeled, linked together and 
related to source code on the second pass through the source code. This 
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Figure 1 . 1 An Overview of the Shatz and Cheng Analysis System 
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"customization” of the templates was based on the premise that each 
statement had a unique statement number. [Ref. 4:pp. 378-380] 

For the Petri Net Analysis Subsystem, Shatz and Cheng relied upon the 
P-NUT suite of tools provided by Rami R. Razouk of the University of 
California, Irvine. [Ref. 4:p.379] 

The Back End Interpreter / Display Subsystem provided a metric report 
that related the results of the Petri net static analysis in the context of the 
source program so as to be an understandable and useful aid to the Ada 
programmer. [Ref. 4:p.378] 

The software analysis methodology proposed by Leveson and Stolzy 
requires prior knowledge of the properties the programmer wants to analyze, 
e. g. , what constitutes a fault, failure, deadlock, etc. [Ref. 3:p. 1]. The 
incorporation of this preliminary analysis information into an automated 
software analysis tool suggests a capability to interactively query the Back 
End Interpreter / Display Subsystem rather than receive a canned metric 
product. These queries must be based upon knowledge, from either the 
programmer or the Interpreter Subsystem, of the source code to Petri net place 
mapping. 

Although principally concerned with a distributed software system’s 
potential communication patterns and complexity metrics [Ref 4.:p. 377; 

Ref. 5], Shatz and Cheng’s concept of an automated petri net translator is 
ideally suited to the area of interactive software analysis. Unfortunately, the 
exclusion of key Ada constructs, the template implementation of the Front 
End Translator Subsystem, and the non-interactive Back End Interpreter/ 
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Display Subsystem limits the usefulness of Shatz and Cheng’s Analysis 
System as a practical interactive software analysis tool. 

C. OBJECTIVES 

It is the objective of this thesis to demonstrate and implement an 
algorithm for the automated translation of Ada source code to a Petri net 
model. This algorithm has an advantage over the template algorithm in that 
it requires only one pass through the source code. In addition, the 
intermediate products produced by this algorithm can facilitate the storing of 
libraries of source code Petri net models. This implementation of an 
automated Ada source code translator utilizes the same parsing technology of 
metrics developed at the request of Naval Weapons Center, China Lake and is 
intended to be the preliminary work for a new automated software analysis 
tool entitled "AdaFlow”. Although "AdaFlow” is not intended to produce a 
metric product, it is designed to demonstrate the versatility of the 
"AdaMeasure” technology and to be the logical companion of the 
"AdaMeasure” metric product. 
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II. REVIEW OETHEORY 



A. PETRI NETS 

Petri nets were originally designed as a tool to model communication 
between asynchronous components of a computer system by Carl Petri [Ref. 
6]. Petri nets have evolved as a modeling tool and have found application in 
such diverse areas of study as software, hardware, economics, and chemistry. 

A formal definition of a Petri net is a five-tuple, $ = (P, T, /, 0, po)> 
where: 

1. P = {pi,p 2 ,— ,pn} is a finite set of places and n ^ 0. 

2. T = t m } is a finite set of transitions; m ^ 0; and the set of 

places and transitions are disjoint, P H T = 0. 

3. I is the input function T => P°, a mapping from transitions to bags of 
places. 

4. O is the output function T => P*, a mapping from transitions to bags of 
places. 

5. po is the initial marking for the net, P => N where N is the set of 
nonnegative integers. [Ref. 3:pp. 396-397] 

A graph structure is most often used to illustrate a Petri net. Standard 
symbols include a circle ”0” to represent a place and a bar " | ” to represent a 
transition. An arrow or arc from a place to a transition defines the place as an 
input to the transition while an arc from a transition to a place defines the 
place as an output to the transition as illustrated in Figure 2.1. [Ref 3:p. 387] 
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In order to illustrate the dynamic nature of a system being modeled, Petri 
nets utilize tokens. The initial marking, po> deposits zero or more tokens in 
each Petri net place. This marking corresponds to the initial state of the 
system. The net is animated by the movement of tokens from input places, 



Input Place 



Marked Place 




Transition 



Output Place 




Enabled Transitions 





Figure 2.1 Standard Petri Net Symbology 

through a transition, to output places. In order for a token to move, the 
transition separating source places and destination places must be enabled. A 
transition is enabled only if each input place to the transition contains at least 
as many tokens as there are arcs from the input place to the transition . 
Examples of enabled transitions are shown in Figure 2.1. In an untimed Petri 
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net, a transition may fire any time after it is enabled. When a transition fires, 
all tokens enabling that transition are removed from their corresponding 
input places and one token is deposited in each of the transition’s output 
places. Transitions continue to fire as long as at least one transition remains 
enabled. [Ref. 3] 

The initial state of the system is defined by the initial marking, po- When 
a transition fires, the new marking of tokens defines a new system state. For 
an untimed Petri net, the enabled transitions may fire in any order. The set of 
all possible states that may exist based on all possible orderings of transition 
firings defines the reachable states for the system. In this thesis, a 
reachability graph will be used to illustrate the reachable states for a system. 

A Time Petri net is a Petri net that is enhanced to include timing 
constraints on the firing of transitions. The addition of timing information 
may limit the reachable states of the system, but may never increase them. 
This principle is key to the analysis technique described by Leveson and 
Stolzy that begins with the untimed reachability states of a system and works 
backward to the real-time properties of a system. [Ref. 3:p. 3891 

B. MODELING COMPUTER SOFTWARE 

In his description of modeling with Petri Nets, Peterson claims that the 
modeling of computer software is ”... perhaps the most common use of Petri 
nets and has the greatest potential for useful results.” [Ref. 7:p. 541 

In modeling, a decision must be made concerning which aspects of the real 
system are to be incorperated into the model. When applied to computer 
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software, Petri net models best illustrate the aspect of software control 

structures. Peterson’s rationale for modeling control structures is as follows: 

Petri nets are meant to model the sequencing of instructions and the flow of 
information and computation but not the actual information values 
themselves. A model of a system, by its nature, is an abstraction of the 
modeled system. As such it ignores the specific details as much as possible. 
If all the details were modeled, then the model would be a duplicate of the 
modeled system, not an abstraction. [Ref. 7:p. 55] 

As flowcharts are a standard means of representing the control structures 

of a program, Peterson utilizes flowcharts as an intermediate form of the 

source code in the translation of concurrent computer software. In his 

description of the translation methodology, single processes in a system of 

concurrent processes are first described in terms of flowcharts. These 

flowcharts are translated to Petri nets, and then combined to yield one Petri 

net representation for a system of concurrent processes. [Ref. 7:pp. 54-68] 

The translation of flowcharts to Petri nets relies on the similarities 

between these two graphical means of representating of a program. In a 

flowchart, nodes model actions or events, while arcs between nodes model 

conditions. In a Petri net, the transitions model actions, while nodes model 

conditions. Peterson’s translation is, therefore, very straightfoward: replace 

the nodes of the flowchart with transitions in the Petri net and the arcs of the 

flowchart with places in the Petri net as illustrated in Figure 2.2. Peterson 

describes a one-to-one correspondence between flowchart arcs and Petri net 

places, while flowchart nodes are represented in different ways, depending on 

the type of the node: computation or decision [Ref. 7: p. 58]. The combining of 

Petri net models for single processes into one model representing a system of 

concurrent processes is accomplished by introducing the concept of 

parallelism and synchronization. 
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Figure 2.2 Translating Flowcharts to Petri Nets [Ref 7:p. 57] 



Peterson describes three ways parallelism can be introduced into a 
software model: 

1 . Simply take the union of all Petri nets to represent the concurrent 
execution of each individual process. Each process has an initial 
marking in the place representing the initial program counter for that 
process. 

2. Utilize the FORK and JOIN operations originally proposed by Dennis 
and Van Horn [Ref. 8]. The FORK and JOIN operations are illustrated 
in Figure 2.3. 

3. Utilize the parbegin and parend control structures suggested by 
Dijkstra [Ref. 9]. This construct is illustrated in Figure 2.4. 
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Figure 2.3 Modeling the FORK and JOIN Operations [Ref 7:p. 60J 




Figure 2.4 Modeling the Parbegin and Parerul Operations LRef 7:p. 61] 
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In his assessment of the first method, Peterson remarks that although it 
introduces a parallelism that cannot be represented in a flowchart, it is still 
not a very useful method of modeling parallelism [Ref. 7:p. 59]. The second 
method is a more accurate depiction of how parallelism would normally be 
introduced into a process in a computer system; however, it limits the number 
of processes that may be spawned to two. The parbegin and parend structure 
offers the accurate depiction of how parallelism would normally be introduced 
without the restriction on the number of processes that may be spawned [Ref. 
7:pp. 59-61] 

The concept of synchronization entails the sharing of information and 
resources between individual processes. This communication between 
processes must be restricted and coordinated in order to ensure correct 
operation of the overall system. Peterson describes classic synchronization 
problems such as the mutual exclusion problem [Ref. 10], the producer / 
consumer problem [Ref. 9], the dining philosophers problem [Ref. 9], and the 
readers / writers problem [Ref. 11], and presents some Petri net solutions to 
these problems. As these classic synchronization problems do not reflect the 
synchronization problems of a specific computer language, Peterson does not 
relate his solutions to a computer software translation algorithm. His 
solutions merely illustrate general methods for modeling general classes of 
synchronization problems. A discussion of Ada’s synchronization mechanisms 
and a specific translation algorithm will be presented in Chapter EH. [Ref. 7: 
pp. 61-69] 

The procedure for modeling computer software outlined by Peterson relies 
on two translations: from source code to flowchart and from flowchart to Petri 
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net. In addition, one must then add Petri net details in order to model 
parallelism and synchronization mechanisms between the Petri nets produced 
from the two translations. Although this procedure will ultimately yield a 
Petri net model of the computer software under study, it is not a procedure 
that is readily automated. The modeling algorithm detailed by Shatz and 
Cheng, although specific to Ada software, overcomes this limitation by 
automating the translation process. This modeling algorithm required two 
steps: 

1 . Preprocessing of the source code which collects "necessary information” 
into some tables for later reference. 

2. Translation of the source code. [Ref. 4] 

The preprocessing step required one complete pass through the source 
code to build the tables required by the translator. As one example of what is 
considered "necessary information” for the preprocessor to collect, Shatz and 
Cheng describe the maintenance of an Entry Call Table. The Entry Call 
Table has four fields: 

1. The name of the calling task. 

2. The name of the called task. 

3. The name of the entry in the called task. 

4. A unique identifier for the entry call. 

In order to uniquely identify entry calls and others information collected by 
the preprocessor, Shatz and Cheng assume each statement has a unique 
statement number. [Ref 4:p. 3801 

The translation phase of the algorithm required a second complete pass 
through the source code. The translator utilized a template table of stored 
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Petri net equivalent models of Ada control structures. These Petri net 
equivalent models and the resulting source program model were stored and 
described in terms of a Petri net abstract grammar. As defined by Shatz and 
Cheng, a Petri net abstract grammar is a triple AG = (P, T, PR), where: 

1. P is a finite set of non-terminal symbols that correspond to places in the 
Petri net. 

2. T is a finite set of terminal symbols that correspond to transitions in the 
Petri net. 

3. PR is a finite set of production rules of the form u => tv, where u and v 
are strings of symbols from P, and t is a symbol from T. 

An initial string is used to represent the initial marking of the Petri Net. 
Figure 2.5 illustrates an example Petri net model and the corresponding 
abstract grammar representation. [Ref. 4:pp.378-379] 

The process of translating Ada constructs consisted of retrieving the 
appropriate Ada construct model from the template table, customizing the 
templates, and linking the templates together. Customizing the templates 
not only uniquely identifies places within the templates, it also provides the 
means to automate the modeling of synchronization mechanisms between 
Petri net models of single processes. Consider the example of Figure 2.6. 

Shatz and Cheng’s templates for Ada’s entry statement and accept statement 
are shown before customization. Customization results in the Ack-entry place 
for both templates receiving the same unique identifier. Therefore, in the 
abstract grammar representation, these two building blocks of Ada’s 
synchronization mechanism are effectively linked. [Ref. 4:p. 380] 
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3. PI => t3 P4 




4. P4 => t4 PI 



with initial string = PI 



Figure 2.5 An Abstract Grammar Representation 
of a Petri Net Model [Ref. 4:p. 384] 




Figure 2.6 Modeling Ada’s Synchronization Mechanism 
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This algorithm for modeling computer software is superior to Peterson’s 
algorithm. Although automated, there exist some notable shortcomings that 
prevent the use of this template algorithm in a general, automated, Ada 
software analysis tool. These shortcomings include: 

1. The algorithm requires multiple passes through the source code. The 
first pass is utilized to determine the underlying structure of the 
program, while the second pass effects the actual translation. 

2. The tables assembled in the first pass do not include scoping 
information and , therefore, do not present a true picture of the 
program’s underlying structure. In a general Ada program, with and 
use clauses can dramatically alter the context of compilation and 
provide direct visability to identifiers without using the "dot” or 
component select notation. If the tables are unable to provide scoping 
information, the constuct being modeled may be misidentified. 

3. The method used to depict parallelism is to provide an initial marking 
for the main procedure and each task in the source code. This is not an 
accurate description of of how parellelism would normally be 
introduced into a process. A more accurate depiction would utilize the 
parbegin and parend structures. 

4. The assumption of unique statement numbers is, perhaps, unrealistic. 
If by "statement number”, one refers to the line of text in the source 
code where the statement is physically located, then the translation 
algorithm imposes restrictions on the language beyond those of the 
Language Reference Manual (LRM) [Ref. 12]. 
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5. The use of templates is a rigid method that does not accurately depict 
the flow of control in a general Ada program. 

C. FRONT-END MACHINE 

Rather than rely on a tool that was only capable of gathering specific 
metric information, Neider and Fairbanks chose to develop a generic Ada 
front-end machine consisting of a lexical analyzer and parser. This front-end 
machine was used to construct an intermediate representation of the source 
program, or derivation tree, which is utilized to collect the information 
necessary to implement the desired metric. [Ref. l:p. 18] 

As this derivation tree determined the underlying structure of the 
program incrementally, while the program was being scanned, the desired 
metric information could be collected in one pass through the source code. 

This is accomplished by effecting emissions of the desired information from 
the front-end machine at appropriate places in the derivation tree. By 
altering these emissions from metric information to Petri net information, the 
front-end machine can be utilized to translate Ada source code to Petri net 
models. 

1. The Modified Ada Grammar 

Nieder and Fairbanks decided on a top-down, recursive-descent 
parsing algorithm as the implementation of the parser. Recursive-descent 
parsers are closely related to the LL(1) subset of the context-free grammars 
and are among the most popular of the compiler parsers [Ref. 13:p. 167]. For 
this reason, it was necessary to ''massage” the Backus-Naur description of the 
Ada language [Ref. 12:Appendix E], a non-LL(l) grammar, into an LL(l)-like 
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grammar capable of being parsed deterministically. In the context of this 
thesis, "massage” refers to the process of removing instances of left recursion 
and then left factoring the grammar so the parser can choose the correct 
production rule based on one token look-ahead. [Ref. l:p. 13] 

Nieder and Fairbanks discovered several instances of left-recursion 
in the Ada grammar. The following excerpt from their thesis illustrates Ada’s 
left-recursive quality for the production rule NAME. Ada’s terminal tokens 
will appear in lower case letters while nonterminals will appear in upper case 
letters: 

The production rules, when taken directly from the LRM, appear as follows: 

NAME => identifier 

=> character literal 

=> string literal 

=S> INDEX COMPONENT 

=> SLICE 

=> SELECTED COMPONENT 

=> ATTRIBUTE 

INDEXED COMPONENT => PREFIX ( EXPRESSION ) 

SLICE => PREFIX ( DISCRETE RANGE ) 

SELECTED COMPONENT PREFIX . SELECTOR 

ATTRIBUTE => PREFIX ’ ATTRIBUTE DESIGNATOR 

PREFIX => NAME 

=> FUNCTION CALL 

When starting with NAME and substituting in the productions, the left 
recursion becomes readily apparent. For example: 

NAME => SLICE => P R E F I X ( I ) I SC R ET E RANGE) => N AM E( DISCRETE RANGE). 

I Ref. 1 :pp 14 15| 

These instances of left recursion required extensive massaging in order to 
yield an LL( 1 ) grammar. The resulting grammar is included as Appendix A. 
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2. Lexical Analysis 



The task of assembling a sequence of source characters into the 
terminal alphabet or tokens of the language is within the province of the 
scanner or lexical analyzer [Ref. 13:p. 18]. There are seven classes of tokens 
that comprise the terminals of the Ada language. These token classes are 
known as identifiers , separators, numeric literals , delimiters, comments, 
character literals , and string literals. In addition, the Ada language recognizes 
a special sub-class of identifier known as reserved words . 

The process of lexical analysis entails reading the source program one 
character at a time and building the tokens deterministically, with one 
character look-ahead, based upon the definition of Ada’s lexical elements as 
described in Chapter Two of the LRM [Ref. 12]. 

Neider and Fairbanks described seven deterministic finite state machines 
capable of recognizing the seven basic token classes of the Ada language. 
These machines will be discussed in greater detail in Chapter IH. [Ref. l:pp. 
18-25]. 

3. Recursive-Descent Parser 

The implementation of Neider and Fairbanks’ recursive-descent 
parser consists of a set of function calls with a one-to-one correspondence to 
the non-terminals of the Modified Ada Grammar. These function calls return 
either a true or false value. A return of false excludes the non-terminal from 
the derivation tree while a return of true indicates that the non-terminal is 
part of the derivation tree. As non-terminals may contain tokens as part of the 
production string, the parser can query the lexical analyzer if the current 
token matches a terminal in the production string. If a match is found, the 
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token becomes a leaf of the derivation tree and a new token is assembled by 
the lexical analyzer. Parsing begins with a call to the function 
COMPILATION, the starting non-terminal of the grammar [Ref. 1]. 
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II. THE METAMORPHOSIS OF "ADAMEASURE” 



"AdaMeasure” is an evolving metric tool that is utilized and maintained 
by the Software Missile Branch of the Naval Weapons Center, China Lake. 
Since it was first published in March of 1987, The "AdaMeasure” front-end 
machine has undergone a significant change in appearance while retaining 
it’s basic functionality. During the course of this thesis, several changes to the 
lexical analyzer and the Modified Ada Grammar were proposed and 
incorporated. Changes to the lexical analyzer were made primarily in the 
interest of speed and readability, while changes to the Modified Ada Grammar 
were made primarily in the interest of regularity. The first two sections of 
this chapter outline these general modifications, while the last section details 
the changes made in the Parser (Appendix C) emissions in order to realize a 
Petri net model of the source code. 

A. LEXICAL ANALYZER 

Prior to this thesis, many of the functional tasks of lexical analysis were 
interspersed throughout the different packages that comprised the front-end 
machine. This thesis sought to group all the functional tasks of lexical 
analysis into one package with an interface that hides the implementation 
details as much as possible. The result of this effort is the Token Scanner 
package.(Appendix H). This package presents an interface that, to the user, 
makes the source file appear as a logical file of Ada tokens. A finite set of 
operations are provided to the user that include the ability to view the token 
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under the read head, view the token that will come under the read head next, 
and the ability to advance the read head one token at a time. In addition, the 
capabilities of the Token Scanner were expanded to include the capability to 
distinguish reserved words from identifiers. This change allowed an efficient 
hash search for reserved words that was hidden from the user, and resulted in 
a significant increase in speed for the front-end machine. 

The implementation of the Token Scanner utilizes a pipe to assemble the 
tokens of the language and a filter to prevent comments and separators from 
ever coming under the read head or into the look-ahead position. The seven 
deterministic finite machines described by Nieder and Fairbanks [Ref. 1] are 
utilized in the pipe to identify the tokens as they are assembled. These 
machines have been enhanced to conform more closely to the exact lexical 
requirements of the LRM. The only lexical requirement the Token Scanner 
does not enforce, is the requirement that each extended digit of a based 
numeric literal be less than the base [Ref. 12:p. 2-5]. These enhancements 
have virtually eliminated the Token Scanner’s reliance on the precondition 
that the source code be correctly compiled prior to being analyzed. 

B. GRAMMAR 

As this thesis progressed, it became apparent that there were many 
productions in the Modified Ada Grammar that could be simplified. Consider 
the original productions that were designed to parse an Ada function: 
FUNCTION UNIT=£ DESIGNATOR FUNCTION_UNIT_TAIL 

FUNCTION UNIT TAIL => is now NAME | GENERIC ACTUAL PART ?| ; 

=> [ FORMAL PART ?| return NAME FUNCTION UODY 
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FUNCTION BODY =» is [ FUNCTION_BODY_TAIL ?] 

=» ; 

FUNCTION BODY TAIL =» separate; 

=> < > ; 

=» SUBPROGRAM BODY 

=» NAMK ; 

These productions were simplified to the following production rule: 



FUNCTION UNIT=» 






DESIGNATOR [ FORMAL PART ?] return NAME is 

SUBPROGRAM BODY 

DESIGNATOR l FORMAL PART ?] return NAME ; 

DESIGNATOR [FORMAL PART ?] return NAME renames 

NAME ; 

DESIGNATOR is SUBPROGRAM BODY 



Another significant change in the grammar concerned the production rules for 



SUBPROGRAM BODY. There were numerous instances of productions 



requiring the sequence: 



[DECLARATIVE PART ?] begin SEQUENCE OF STATEMENTS [exception 

[EXCEPTION HANDLER]* ?] end IDESIGNATOR ?| ; 

Rather than duplicate this sequence for each production, the productions 

requiring this sequence were modified to utilize the SUBPROGRAM BODY 

production rules. This simplification relies on the precondition of correctly 

written code verified by a compiler prior to being analyzed. The Modified Ada 

Grammar listed in Appendix A contains all the changes to the original 

grammar and is the current grammar utilized in both "AdaMeasure” and 

"AdaFlow”. 



C. PARSER EMISSIONS 
1. Code Blocks 



A key issue in any source code to Petri net translation algorithm is 
the method used for transforming source code space into Petri net space. 

Shatz and Cheng [Ref. 4] chose to use "statement numbers” that corresponded 
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to the line of text in the source code where the statement was physically 
located. This method of transformation assumes that each Ada control 
structure has a unique statement or line number. This assumption is 
unrealistic as it imposes restrictions on the language beyond those of the 
LRM. 

One method of transforming source code space to Petri net space is 
suggested by the very aspect of computer software Petri nets model best: 
control structures. Software control structures not only correspond to 
transitions in a Petri net, they also serve to separate source code into "blocks” 
of code that correspond to unique Petri net places. It is not sufficient, 
however, to rely on control structures as the only demarcation of where these 
code blocks begin and end. One must also consider the possible source code 
destinations that a control structure can transition to when executed. These 
possible destinations include labels , procedures , functions y and task entries. In 
general, a control structure is located in the current code block and denotes 
the end of that code block, while a destination denotes the end of the current 
code block and is located in the next code block. The execution of control 
structures is simply the order in which these code blocks are interconnected. 

Consider the simple Ada program and corresponding Petri net places 
of Figure 3.1. The procedure entitled MAIN defines a destination of a 
procedure call statement and, therefore, begins a new code block. A procedure 
is a scope defining construct that, when viewed from the perspective of the 
invoker, can be considered as one large code block or a super-place in the 
corresponding Petri net. The details of control flow internal to the procedure 
are not visible to the outside world. All the declarations that follow MAIN are 
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procedure MAIN is 

typeGRADE HOOK is array (positive range 1..10)<>f 

natural; 

INDEX : natural; 

TOTAL : natural ; 

AVERAGE : natural; 

STUDENT : GRADE BOOK; 

begin 

INDEX := 0; 

TOTAL;= 0; 

< < ADD AGAIN > > 

INDEX — INDEX + I; 

TOTAL := TOTAL + 

STUDENT( INDEX); 
ifGNDEX = 10) then 
goto CONTINUE; 

else 

goto ADD_AGA1N; 
end ii‘; 

< < CONTINUE > > 

AVERAGE := TOTAL/ 10; 
end MAIN; 



procedure MAIN 




Figure 3.1 Transforming Source Code Blocks to Petri Net Places 



within the same code block as MAIN. The reserved word begin labels the start 
of MAIN’s internal control structure and starts a new code block. The label 

ADD AGAIN ends the first internal code block and is located in the next 

code block. The if statement labels the root location of a multi-way decision 
path and, therefore, is the beginning of a new code block. The first path of the 
if statement is an unconditional jump to the label CONTINUE. This 
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statement is part of, and denotes the end of, the i/code block. The else clause 
of the ^statement reactivates the root location as the current code block. The 
goto statement of the second path has the same effect on the if code block as 
the goto of the first path. The end if statement is a possible destination for any 
of the paths of the i/statement and, as such, denotes the end of the code block 
in the current path if it has not already ended. The end i/statement begins, 
and is located in, a new code block. The CONTINUE label ends the end if code 
block and is located in the next code block. The end of procedure MAIN labels 
a possible destination for control statements such as return ; therefore, it 
denotes the end of the current code block and is the first statement in the next 
code block. Upon completing the parse of MAIN’s subprogram body we exit 
the last internal code block and the enclosing procedure code block. 

A necessary condition for translation is that for every code block in 
the source program, there must exist a unique Petri net place. This property 
is not commutative as pseudo-places exist in Petri nets that have no 
corresponding code blocks in the source program. These pseudo - places will be 
discussed when we consider the Parser’s emissions for Petri nets. 

Due to the front-end machine’s ability to determine the deep, 
underlying structure of Ada programs, it is possible to determine when a code 
block, and the related Petri net place, begins and ends on the basis of where 
we are in the grammar rather than where we are in a text file. Based on this 
determination, the Parser emits information to the Code Blocker (Appendix 
F). 

The Code Blocker is responsible for assigning a unique Petri net place 
number to each code block that is entered by the Parser. In addition, the code 
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blocker accepts and stores information from the Parser that relates the Petri 
net places to their locations in the text file. Although not currently used by 
the system, this information is maintained for two reasons: 

1. It is easier for the user to relate Petri net places to source code locations 
rather than grammar locations. 

2. It is anticipated that, at a later date, an interactive, high level user 
interface will be incorporated that will require this mapping 
information. 

2. Symbol Table 

Simply stated, the function of a symbol table is to store and retrieve 
identifiers and their associated properties. There are two properties of 
interest for a source code to Petri net translator: an identifier’s attribute and 
location. 

An identifier’s attribute or classification is used to determine 
whether the identifier is a control structure or a possible destination of 
executing a control structure. If a control structure, the attribute uniquely 
classifies the type of control structure that will later be modeled. The 
attribute also determines whether or not the identifier is the beginning of a 
new scope. 

As Ada is a statically scoped language with strict visibility rules, any 
symbol table used with Ada must preserve this scoping information. In 
addition, an Ada symbol table must allow for the capability to provide 
visibility of identifiers in previously exited scopes. This requirement is a by- 
product of Ada’s package facility. 
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Symbol table location information, as it applies to a Petri net 
translator, relates the identifier to a unique code block and, therefore, a 
unique Petri net place. As an identifier may be declared before the location or 
code block is known, the capability to update an identifier’s location must be 
supported by the symbol table. 

By utilizing the location information from the Code Blocker, the 
front-end machine has all the additional resources required to manage the 
Symbol Table (Appendix E). Returning to the example of Figure 3.1, and 
ignoring the Parser’s management of the Code Blocker for entering, exiting, 
and reactivating code blocks, the Parser’s management of the Symbol Table 
can be illustrated. 

When the Parser encounters the identifier MAIN, it obtains the 
current code block number from the Code Blocker, say ”1”, and inserts the 
identifier into the Symbol Table with a procedure declaration attribute and a 
location of ”1”. As a procedure declaration is a scope defining construct, this 
action causes the Symbol Table to enter a new scope. 

The sequence of statements within a procedure body may contain a 
return statement. A return statement is used to complete the execution of the 
innermost enclosing procedure and may be thought of as an unconditional 
transfer to the end of the procedure. For this reason, the Parser makes an 
entry in the symbol table for the last code block in the procedure with a label 
attribute and a location of "0” or undefined. As each label in Ada must have a 
unique identifier, the reserved word end is used as the identifier for the last 
code block in MAIN. This method of labeling destination code blocks that do 
not have a user defined label ensures uniqueness and avoids clashes with user 
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defined labels as programmers are restricted from using a reserved word as a 
label identifier. 

The next identifier that results in a Symbol Table entry is the label 

ADD AGAIN. The Parser inserts ADD AGAIN with a label attribute and 

the code block location, now "3”. 

Upon parsing the if statement, the Parser inserts the identifier if in 
the Symbol Table with a special attribute that identifies the if control 
structure and the location "4”. This attribute causes the Symbol Table to 
enter a new scope. The Parser then inserts the if statement’s corresponding, 
undefined end label. 

The goto statement of the first if statement path causes the Parser to 
search the Symbol Table for the identifier CONTINUE. When the Symbol 
Table informs the Parser that CONTINUE is not declared, the Parser 
assumes that the goto statement is an implicit declaration of the label 
CONTINUE. This causes the Parser to insert a label for CONTINUE with an 
undefined code block location in the Symbol Table. The goto statement of the 
second if statement path causes the Parser to search the Symbol Table for the 

identifier ADD AGAIN. The Symbol Table finds the label and reports this 

fact to the Parser. The Parser then checks to see if the location is defined (non- 
zero). If not defined, the Parser would update the Symbol Table entry to the 
current code block number. 

The end if statement results in the Parser ordering the Symbol Table 
to search for the end label. When the Symbol Table finds the end label, the 
Parser then updates the label’s location to the correct code block number of ”5” 
and orders the Symbol Table to exit the scope. 
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When the CONTINUE label is encountered, the Parser orders the 
Symbol Table to search for the identifier CONTINUE. The Symbol Table 
finds the label and reports this fact to the Parser. The Parser then updates the 
label’s location to the current code block number of ”6”. 

The end MAIN statement results in the Parser ordering the Symbol 
Table to search for the end label. When the Symbol Table finds the end label, 
the Parser then updates the label’s location to the correct code block number of 
"7” and orders the Symbol Table to exit the scope. Figure 3.2 illustrates the 
scoped symbol table at the end of the parse. 




Figure 3.2 Storing Source Code Blocks in a Symbol Table 



Ada supports the capability for a programmer to declare and invoke 
procedures, function, packages, tasks and entries before their corresponding 
bodies have been parsed. This capability is akin to the Pascal forward 
declaration. In order to handle these forward declarations, the Parser inserts 
the identifier, the appropriate declaration attribute, and an unknown 
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location. The Parser then inserts the corresponding end label with an 
unknown location and exits the scope. When the declaration’s corresponding 
body is parsed, the Parser inserts the same identifier, with the appropriate 
body attribute, and the known code block location. This causes the Symbol 
Table to automatically search for and update the environment of definition, 
and enter that environment’s scope. 

3. Petri Net Transitions 

Petri net transitions model the execution of control structures and 
connect Petri net places. Petri net places can be the source or destination of a 
transition For the purpose of this thesis, Petri net places will be divided into 
three categories: known Petri net places, unknown Petri net places, and 
pseudo- places. Known Petri net places correspond to the code block that is 
currently being parsed, while unknown Petri net places correspond to either a 
code block declared in the symbol table, or the next code block to be 
encountered. In all cases, known and unknown Petri net places correspond to 
a unique code block in the source. Pseudo-places are Petri net places that are 
required to model a control structure but have no corresponding location in 
source code. As an example of all three places, consider Figure 3.3 and the 
depiction of Ada’s synchronization mechanism. When an entry to a task is 
called, the procedure that called the entry waits at the rendezvous until the 
invoked task accepts the entry and finishes processing the accept statements. 
Only then can the procedure that called the entry continue processing. Figure 
3.3 depicts the two transitions required to model this control structure. The 
current code block is known by the Parser when the entry call statement is 
encountered. If the assumption that this is a correct Ada program is true, 



31 




Figure 3.3 Known Places, Unknown Places, and Pseudo-Places 

then the task specification must have been parsed and at least the entry code 
block and the corresponding end entry code block are in the Symbol Table. It 
is not necessary for the locations to be known yet. In order to model the 
requirement for the invoking procedure to wait at the rendezvous until the 
accept statements of the entry are through being processed, it is necessary to 
use a pseudo - place that has no corresponding code block in source code. The 
second transition models the completion of the entry. The token from the 
pseudo - place and the end entry code block act together to enable the transition 
for the invoking procedure to continue processing. 

In this translater, the Parser emits known and unknown Petri net 
place information together with the type of control structure to be modeled to 
the Net Generator (Appendix D). For known Petri net places, the Parser 
emits the current code block number as provided by the Code Blocker. For 
unknown Petri net places, the Parser emits a pointer or access to the 
appropriate code block’s entry in the Symbol Table. The Net Generator is 
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responsible for translating the control structure information into transitions 
between the known and unknown Petri net places. In addition, when it is 
necessary to use a pseudo-place to realize a model, the Net Generator grabs a 
unique location from the Code Blocker. During the course of this thesis, 
psuedo-places were only found necessary to realize models for procedure calls 
and entry calls. All other control structures were capable of being modeled by 
transitions between known and unknown Petri net places. 

One special control structure is used so often it deserves special 
mention. In the Net Generator, this special control structure is called 

CONNECT BLOCKS. Consider Figure 3.4 which represents the complete 

Petri net model for the previous example of Figure 3.1. The label 

ADD AGAIN, although it signifies a possible destination of a control 

structure’s execution, does not constitute a break in the sequential execution 
of MAIN. As the Parser knows the location associated with the begin code 

block, and the location associated with the ADD AGAIN code block. The 

Parser simply emits these two known Petri net places to the Net Generator 
with the special control structure CONNECT BLOCKS. 

The Net Generator stores the Petri net model in an abstract 
representation similiar to the abstract grammar described by Shatz and 
Cheng [Ref. 4] . The reason for utilizing an intermediate representation of the 
Petri net model is to give the Symbol Table and Parser an opportunity to 
resolve unknown Petri net places. By storing access variables to the unknown 
Petri net places in the Symbol Table as part of the abstract representation of 
the Petri net model, the Symbol Table will automatically update the location 
of unknown Petri net places referenced in the Net Generator. For the 
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procedure MAIN is 

type GRADE ROOK is array (positive range I. .10) of 

natural; 

INDEX : natural; 

TOT A I, : natural ; 

A VERAGE : natural; 

STUDENT : GRADE BOOK; 

begin 

INDEX ;= 0; 

TOTAL := 0; 

< < ADD AGAIN > > 

INDEX := INDEX + 1; 

TOTAL := TOTAL + 

STUDENT(INDEX); 
il'GNDEX = 10) then 
goto CONTINUE; 

else 

goto ADD AGAIN; 

end if; 

< <C()NTINUE> > 

AVERAGE := TOTAL/ 10; 
end MAIN; 



procedure MAIN 




Figure 3.4 Transforming Control Structures to Transitions 



unknown places that signify the next code block to be encountered, the Net 
Generator simply waits for the Parser to emit the next control structure. If 
the preceding model has an abstract representation that ends with an 
unknown place that is not a Symbol Table code block, the Net Generator 
chooses the next known code block location from the next Parser emission. As 
a correct Ada program is assumed and the question of Ada’s separate 
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compilation facility has not as yet been addressed , all unknown Petri net 
places must be resolved by the end of the source code’s parse. Only when the 
unknown places are resolved can we hope to generate a valid Petri net model 
of the source code. 

Another reason for utilizing an intermediate representation of the 
Petri net model is that different Petri net analyzers may require a different 
specific input language. By simply adding a translation algorithm to the Net 
Generator, the abstract representation of the model can be translated to 
various Petri net analyzer input languages. The Net Generator has one 
translator already defined for the P-NUT set of tools [Ref. 14]. 
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IV. "ADAFLOW” 



"AdaFlow” is a concept for a Petri net based, interactive Ada program 
analyzer. This preliminary work concentrates on, and suggests a 
methodology for, the automatic production of Petri net models of Ada 
programs. The products of this translation method have been tailored to 
conform to the input format of an existing Petri net analyzer entitled P-NUT. 
The first section of this chapter briefly describes the P-NUT suite of tools and 
the capabilities these tools offer. The following sections of this chapter 
describe in detail the products produced by the translator and the 
environment in which the translator and P-NUT perform. 

A. THE ANALYZER 

P-NUT is a set of tools developed by the Distributed Systems Project in 
the Information and Computer Science Department of the University of 
California, Irvine. The tools were constructed primarily to assist researchers 
in applying Petri net analysis techniques in the design of distributed systems. 
The P-NUT suite of tools creates and manipulates three types of objects: Petri 
nets, reachability graphs and execution traces. 

Petri nets are input to the system in textual form and are transformed by 
P-NUT into an internal representation of a Petri net. It is the function of the 
translator to provide the Petri net in this textual form. For a complete 
discussion of P-NUT’s input language, the reader is referred to Reference 14. 



36 



Reachability graphs represent the state-space of a Petri net while 
execution traces represent portions of the state space. P-NUT has the 
capability to produce, analyze and display both timed and untimed 
reachability graphs from the internal representation of a Petri net. P-NUT 
also allows an execution trace to be converted into a partial reachability graph 
which can be analyzed and displayed in the same manner as a reachability 
graph produced from the internal representation of a Petri net. 

The most powerful and innovative tool in P-NUT is a tool entitled 
Reachability Graph Analyzer (RGA) (Ref. 15). RGA reads the internal 
representation of a Petri net and its associated reachability graph and allows 
the user to do computer-assisted, interactive analysis, or "ask questions” 
about the model, using the language of first order predicate calculus with the 
addition of branching-time temporal logic operators. This interactive analysis 
capability is ideally suited to the concept of "AdaFlow”. 

B. THE TRANSLATOR PRODUCT 

The following example demonstrates the modeling capabilities of the 
proposed translation method by producing a simple railroad crossing model 
similar to the model analyzed by Leveson and Stolzy [Ref. 3]. 

Figure 4.1 illustrates the original model used by Leveson and Stolzy to 
demonstrate their technique for analysis of real-time systems. Although 
there is no combination of Ada control structures that can exactly duplicate 
the places and transitions of the model in Figure 4.1 the following Ada 
program realistically portrays how an Ada task may be written to handle such 
a problem: 
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Figure 4.1 A Petri Net Model of a Simple Railroad Crossing 



procedure RAIL ROAD CROSSING is 

task COMPUTER is 
entry APPROACH; 
entry DEPART; 
end COMPUTER; 

task GATE KEEPER is 

entry LOWER GATE; 

entry RAISE GATE; 

end GATE KEEPER; 

task body COMPUTER is 
begin 
loop 

accept APPROACH do 
null; 

end APPROACH; 

GATE KEEPER. LOWER GATE; 

accept DEPART do 
null; 

end DEPART; 

GATE KEEPER. RAISE GATE; 

end loop; 

end COMPUTER; 



task body GATE KEEPER is 

begin 

loop 

accept LOWER GATE do 

null; 

end LOWER GATE; 

accept RAISE GATE do 

null; 

end RAISE GATE; 

end loop; 

end GATE KEEPER; 

begin 

COMPUTER. APPROACH; 

< <»EKORE_CROSSING> > null; 

< < WITIIIN_CROSSING> > 
COMPUTER. DEPART; 

< < PAST CROSSING > > null; 

end RAIL ROAD CROSSING; 
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The task entitled COMPUTER represents the software for the railroad 

crossing system, while the task entitled GATE KEEPER and the main 

procedure represent a test harness for the COMPUTER software. 

Assuming that this program is stored in a file entitled TRAIN2.ADA, a 
typical session with the "AdaFlow” translator would begin: 

WELCOME TO ADAFLOW 

ENTER THE NAME OF AN ADA SOURCE FILE TO MODEL 
The user would respond with TRAIN2.ADA. The "AdaFlow” translator would 
notify the user: 

PARSING BEGINS . 

When "AdaFlow” has finished the translation, it gives the final message: 

. . . PARSE SUCCESSFUL 

and exits to the operating system. "AdaFlow” creates two files. The first file 
is named A. OUT and it contains the Petri net model of the source code written 
in the P-NUT input language. The second file, PLACE.DAT, is provided for 
the user to relate Petri net places to lines of text in the source code. For the 
Ada program stored in TRAIN2.ADA, the A. OUT file would appear as: 



1 1 : pi - > p2, p3, p 1 9 


1 1 7 : p26, p25 -> p27 


t2: p3 -> p4 


tl 8: p27-> p28, p29 


t3: p4 -> p5 


tl 9: p29 -> p21 , p30 


t4: p6, p5 -> p7 


t20: p2 -> p3l 


t5: p7 -> p8, p9 


t2l : p3l -> p6, p32 


t6: p9 - > p22, plO 


t22: p8, p32 -> p33 


t7: p24, p 1 0 - > pi 1 


t23: p33 -> p34 


t8: pi 2, pi 1 -> pi 3 


t24: p34 -> pi 2, p35 


t9: p 1 3 - > p14, pi 5 


t25: pi 4, p35 -> p36 


tIO: pi 5 - > p26, p 1 6 


t26: p36 -> p37 


til: p28, p 1 6 - > p 1 7 


t27: p30, pi 8, p37-> p38 


tl 2: p 1 7 - > p5, p18 


<p1 > 


tl 3: p 1 9 - > p20 




1 14: p20 -> p21 




tl 5: p22, p21 -> p23 




tl 6: p23 - > p24, p25 
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The PLACE.DAT file relating locations in the source code to Petri net places 
would appear as: 



LOCATION 


CODE BLOCK LABEL 


STARTING LINE 


ENDING LINE 


pi 


START 


0 


0 


P2 


PROCEDURE CODE BLOCK 


1 


40 


P3 


TASK CODE BLOCK 


10 


22 


p4 


BEGIN SUBPROGRAM 


11 


12 


p5 


LOOP BLOCK 


12 


13 


p6 


ENTRY BLOCK 


13 


13 


p7 


BEGIN ACCEPT STATEMENTS 


13 


14 


p8 


END ENTRY BLOCK 


15 


15 


p9 


ENTRY CALL 


15 


16 


plO 


WAIT RENDEZVOUS 


0 


0 


pi 1 


ACCEPT STATEMENT 


17 


17 


pi 2 


ENTRY BLOCK 


17 


17 


P 1 3 


BEGIN ACCEPT STATEMENTS 


17 


18 


p14 


END ENTRY BLOCK 


19 


19 


pi 5 


ENTRY CALL 


19 


20 


p 1 6 


WAIT RENDEZVOUS 


0 


0 


pi 7 


END LOOP 


21 


21 


p18 


END SUBPROGRAM 


22 


22 


p 1 9 


TASK CODE BLOCK 


23 


33 


p20 


BEGIN SUBPROGRAM 


24 


25 


p21 


LOOP BLOCK 


25 


26 


p22 


ENTRY BLOCK 


26 


26 


p23 


BEGIN ACCEPT STATEMENTS 


26 


27 


p24 


END ENTRY BLOCK 


28 


28 


p25 


ACCEPT STATEMENT 


29 


29 


p26 


ENTRY BLOCK 


29 


29 


p27 


BEGIN ACCEPT STATEMENTS 


29 


30 


p28 


END ENTRY BLOCK 


31 


31 


p29 


END LOOP 


32 


32 


p30 


END SUBPROGRAM 


33 


33 


p3 1 


BEGIN SUBPROGRAM 


34 


35 


P32 


WAIT RENDEZVOUS 


0 


0 


p33 


LABELLED BLOCK 


36 


37 


p34 


ABELLED BLOCK 


37 


38 


p35 


WAIT RENDEZVOUS 


0 


0 


p36 


ABELLED BLOCK 


39 


39 


p37 


END SUBPROGRAM 


40 


40 


p38 


STOP 


0 


0 



The places that have a STARTING LINE and ENDING LINE of "0” are 



pseudo-places manufactured by the Net Generator. 
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Figure 4.2 illustrates the Petri net model of the train crossing produced 
by AdaFlow. By including a software test harness, a Petri net model for the 
software and the software’s environment was realized. This model is 
significant in that it is capable of system’s level, automated, interactive 
analysis for properties such as safety and deadlocks by utilizing RGA. 

It should be noted that "AdaFlow” assumes that the main procedure and 
all declared tasks activate simultaneously as modeled by the parbegin and 
parend control structure. Although not shown in Figure 4.2, execution of a 
package’s sequence of statements or initialization before the parbegin has 
been modeled, but is not reachable. The first code block for a package’s 
sequence of statements is never linked to the rest of the model. 

C. ENVIRONMENT 

This preliminary work is written in Ada and utilizes the same front-end 
machine as the automated metric tool "AdaMeasure”. "AdaFlow” was 
originally written and compiled on the Meridian AdaVantage™ Compiler 
(Compiler Release 2.0). In order to install and operate the AdaVantage 
compiler, a target system must possess: 

• MS-DOS or PC-DOS version 2.1 or later. 

• A hard disk (typically 5MB or larger). 

• 640K bytes of Random Access Memory in the base memory area. 

In addition, an 8087 or 80287 floating point math coprocessor must be 
installed for programs that use floating point operations. "AdaFlow” 
currently does not require floating point operations. 



AdaVantage is a trademark of Meridian Soft ware Systems, Inc. 
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Figure 4.2 An AdaFlow Model of a Simple Railroad Crossing 
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Release 2.2 of P-NUT is only suitable for systems running a compatible 
version of 4.2bsd UNIX®. P-NUT was successfully installed at the Naval 
Postgraduate School on a SUN-3 workstation. To facilitate software analysis 
in the current form of "AdaFlow”, the "AdaFlow” source code was transferred 
to the SUN workstation and was successfully recompiled using V ADS® 

(Verdix Ada Development System, Version 5.5 for SUN-3) without 
modification. 

All the P-NUT software in release 2.2 is available free of charge from the 
Information and Computer Science Department of the University of 
California, Irvine. The point of contact for inquiries concerning P-NUT is 
Professor Rami Razouk. Release 2.2 includes the C source code and binaries 
for SUN-3’s. If operating in a different 4.2bsd UNIX environment, a Makefile 
is provided to facilitate recompilation of the source code. 

The Ada source code for "AdaFlow” is available free of charge from the 
Computer Science Department of the Naval Postgraduate School. The point of 
contact for inquiries concerning "AdaFlow” is LCDR John Y urchak. 
Supplementary information concerning compilation of the source code is 
provided along with the source code. 



UNIX is a registered trademark of the Bell System 
VADS is a registered trademark of the Verdix Corporation 
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V. CONCLUSION 



Ada is the Department of Defense’s language of choice for programming 
embedded, real-time systems. The decision to use Ada has hastened the need 
for Ada-based, automated software engineering tools. The Petri net-based 
method proposed by Leveson and Stolzy for analyzing real-time systems has 
considerable merit; however, hand production of Petri net models for large, 
complicated systems is a tedious and error-prone process at best. This thesis 
has described and demonstrated that an efficient method exists for the 
automated translation of Ada source code to Petri nets. By adding additional 
features of the Ada language such as separate compilation and a library 
manager to "AdaFlow”, the production and analysis of Petri net models on the 
systems scale is possible. 

A. THE FUTURE 

As the primary purpose of this thesis was to describe and demonstrate a 
methodology for the translation of Ada source code to Petri net models, not all 
control structures and features of the Ada language have actually been 
implemented in "AdaFlow”; however, every design decision was made to 
facilitate the addition of these features. For example, the choice to utilize a 
scoped symbol table enables one to capitalize on Ada’s separate compilation 
facility at a later date. By adding a library manager to respond to Ada’s with 
statement, it is possible to maintain a library of Petri net models. These Petri 
net models could be of other Ada programs or pre-defined "environment 
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models” that could be referenced like Ada programs for systems testing of the 
software. It is envisioned that a library manager would operate by pre- 
loading the Net Generator with a package’s Petri Net model, and the Symbol 
Table with a package’s scoped identifiers and properties. 

The Modified Ada Grammar, although able to parse a general Ada 
program, was developed specifically with metrics in mind. There are a 
number of ways to massage a grammar to appear LL(1). In their 
implementation of metrics, Neider and Fairbanks did not have to coordinate 
searching a scoped symbol table with the grammar. The massaged production 
rules for NAME reflect this bias. When the same production rules are used 
while trying to coordinate the search of a scoped symbol table, the grammar 
becomes hard to read and difficult to use. In "AdaFlow” only simplistic 
coordination efforts were taken with respect to the production rules for 
NAME. It was considered more important to demonstrate rather than perfect 
this capability. As searching the scoped symbol table is necessary to ascertain 
if an identifier is a procedure call, a function call, or a task entry, the logical 
candidate for change is the grammar. Future work should include re- 
massaging this portion of the Modified Ada Grammar to facilitate the 
coordination of searching a scoped symbol table. 

Discussion of analysis of the Petri net models produced by "AdaFlow” has 
purposely been minimized. For the purpose of this thesis, it is sufficient to 
note that powerful automated analysis tools such as P-NUT’s RGA are 
currently available. As noted previously, RGA utilizes an input language of 
first order predicate calculus with the addition of branching- time temporal 
logic operators. Although this method of interactive analysis is powerful, it 
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limits the usefulness of the tool to those who have a firm understanding of 
predicate calculus. Future work on "AdaFlow” should include the design and 
addition of a high-level, user-friendly interface to this analysis tool. This 
interface should be able to take user queries and formulate the mathematical 
expressions understood by RGA. 

In the train crossing example presented in Chapter IV, integration of 
"AdaFlow” software models with environment models was demonstrated by 
modeling a software test harness. Although this method served to 
demonstrate the principle of software analysis at the system level, the test 
harness has limitations in modeling the true environment the software may 
encounter. In related Petri net research at the Naval Postgraduate School, 
Lewis (Ref. 16 ) describes the analysis of a proposed, but never developed, real- 
time embedded missile software package. This analysis is conducted at the 
system level using Petri net models of the environment constructed by hand. 
Further research into using "AdaFlow” to automate the integration of these 
environment models with the software under analysis is warranted. 

It is hoped that as the concept and features of "AdaFlow” are fully 
developed, this software tool will become a valuable aid in the design and 
testing of Ada programs for real-time, embedded applications. 
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APPENDIX A 



MODIFIED ADA GRAMMAR 



(9.10) (parser3) 

ABORT STATEMENT => NAME [, NAME]* ; 

(9.5) (parserl) 

ACCEPT STATEMENT => identifier [(EXPRESSION) ?] [FORMAL_PART ?] 

[do SEQUENCE OF STATEMENTS end [identifier ?] ?] ; 

(4.3) (parser3) 

AGGREGATE =» (COMPONENT_ASSOCIATION [, COMPONENT_ASSOCIATION]* ) 

(4.8) (parser3) 

ALLOCATOR =» SUBTYPE_INDlCATION ['AGGREGATE ?] 

(3.6) (parser3) 

ARRAY TYPE DEFINITION =* (INDEX CONSTRAINT of SUBTYPE INDICATION 

(5.2) (parser2) 

ASSIGNMENT OR PROCEDURE CALL =£ NAME : = EXPRESSION; 

=> NAME; 



(4.1.4) (parser3) 

ATTRIBUTE DESIGNATOR =* identifier [(EXPRESSION) ?] 

=» range [(EXPRESSION)?] 

=> digits [(EXPRESSION)?] 

=> delta [(EXPRESSION)?] 

(3.1) (parserl) 

BASIC DECLARATION =£ type TYPE DECLARATION 

subtype SUBTYPE_DECLARATION 
=> procedure PROCEDURE_UNIT 
=» function FUNCTION_UNIT 
=£ package PACKAGE_DECLARATlON 
generic GENERIC_DECLARATION 

=» IDENTIFIER DECLARATION 

=» task TASK DECLARATION 

(3.9) (parserl) 

BASIC DECLARATIVE ITEM BASIC DECLARATIVE 

=> REPRESENTATION CLAUSE 

=> use WITH OR USE CLAUSE 
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(10.1) (parserO) 

BASIC UNIT => LIBRARY UNIT 

SUBUNIT 

(4.5) (parser4) 

BINARY ADDING OPERATOR =* + 

=> - 
=* & 

(5.6) (parserl) 

BLOCK STATEMENT =* [declare DECLARATIVE PART ?] begin 

SEQUENCE OF STATEMENTS [exception 

[EXCEPTION HANDLER] v ?] ?] end [identifier ?] ; 

(5.4) (parserl) 

CASE STATEMENT => EXPRESSION is [CASE STATEMENT ALTERNATIVE] + end case ; 

(5.4) (parserl) 

CASE STATEMENT ALTERNATIVE when CHOICE [| CHOICE]* = > 

SEQUENCE OF STATEMENTS 



(3.7.3) (parser3) 

CHOICER EXPRESSION [..SIMPLE_EXPRESSlON ?] 

=> EXPRESSION [CONSTRAINT?] 

=> others 

(10.1) (parserO) 

COMPILATION => [COMPILATION UNIT] * 

(10.1) (parserO) 

COMPILATION U NIT => CONTEXT_CLAUSE BASIC_UNIT 

(4.3) (parser3) 

COMPONENT ASSOCIATION => [CHOICE [| CHOICE]* = > ?] EXPRESSION 

(3.7) (parse r2) 

COMPONENT DECLARATION => IDENTIFIER LIST : SUBTYPE INDICATION 

[: = EXPRESSION ?] ; 

(3.7) (parser2) 

COMPONENT LIST => [COMPONENT DECLARATION]* [VARIANT PART ?] 

=> null ; 

(5.1) (parserl) 

COMPOUND STATEMENT =* if IF STATEMENT 

=> case CASE STATEMENT 

=* LOOP STATEMENT 

=> BLOCK STATEMENT 

=> accept ACCEPT_STATEMENT 
SELECT STATEMENT 
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(3.2) (parser2) 

CONSTANT TERM => array ARRAY TYPE DEFINITION [: = EXPRESSION?]; 

=> : = EXPRESSION ; 



(3.3.2) (parser3) 

CONSTRAINT => range RANGES 
=$> range < > 

=> digits FLOATING OR FIXED POINT CONSTRAINT 

=» delta FLOATING OR FIXED POINT CONSTRAINT 

=> (INDEX CONSTRAINT 

(10.1) (parserO) 

CONTEXT CLAUSE =» [with WITH_OR_USE_CLAUSE 

[use WITH OR USE CLAUSE]* ]* 

(3.9) (parserl) 

DECLARATIVE PART =£ [BASIC DECLARATIVE ITEM]* [LATER DECLARATIVE ITEM]* 

(9.6) (parser3) 

DELAY STATEMENT => SlMPLE_EXPRESSlON ; 

(6.1) (parser2) 

DESIGNATOR => identifier 

=£ string literal 

(3.6) (parser3) 

DISCRETE RANGE => RANGES [CONSTRAINT ?] 

(3.7.1) (parser2) 

DISCRIMINANT PART => (DISCRIMINANT_SPECIFlCATlON 

[; DISCRIMINANT SPECIFICATION]* ) 



(3.7.1) (parser2) 

DISCRIMINANT SPECIFICATION => IDENTIFIER LIST : NAME [: = EXPRESSION ?] 

(9.5) (parser2) 

ENTRY DECLARATION => entry identifier [(DISCRETE RANGE) ?] 

[FORMAL PART ?] ; 

(3.5.1) (parser4) 

ENUMERATION LITERAL =» identifier 

=» character literal 



(3.5.1) (parser4) 

ENUMERATION TYPE DEFINITION => (ENUMERATION LITERAL 

[.ENUMERATION LITERAL]*) 



(11.1) (parser2) 

EXCEPTION CHOICE => NAME 

=> others 
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(11.2) (parserl) 

EXCEPTION HANDLER when EXCEPTION_CHOICE [| EXCEPTION_CHOICE]* 

= >SEQUENCE OF STATEMENTS 



(8.5) (parser2) 

EXCEPTION TAIL => ; 

=> renames NAME; 



(5.7) (parser3) 

EXIT STATEMENT =4> [NAME ?] [when EXPRESSION ?] ; 

(4.4) (parser3) 

EXPRESSION => RELATION [RELATION TAIL ?] 

(4.4) (parser3) 

FACTOR => PRIMARY [** PRIMARY ?] 

=£ abs PRIMARY 
=> not PRIMARY 

(3.5.7) (parser3) 

FLOATING OR FIXED POINT CONSTRAINT =» SIMPLE_EXPRESSION [range RANGES 

?] 

(6.4) (parser4) 

FORMAL PARAMETER => identifier = > 

(6.1) (parser2) 

FORMAL PART =>(PARAMETER_SPECIFICATION [; PARAMETER SPECIFICATION]* ) 

(6.1) (parserl) 

FUNCTION UNIT => DESIGNATOR [FORMAL_PART ?] return NAME is 

SUBPROG RAM_BODY 

=> DESIGNATOR [FORMAL PART ?] return NAME ; 

=» DESIGNATOR [FORMAL PART ?] return NAME renames NAME ; 

=> DESIGNATOR is SUBPROGRAM BODY 



(12.1) (parser2) 

GENERIC ACTUAL PART (GENERIC_ASSOCIATION [, GENERlC_ASSOCIATION]* ) 

(12.1) (parser2) 

GENERIC ASSOCIATION => [GENERIC FORMAL PARAMETER ?] EXPRESSION 

(12.1) (parserl) 

GENERIC DECLARATION => [GENERIC PARAMETER DECLARATION ]* 

GENERIC FORMAL PART 



(12.1) (parser2) 

GENERIC FORMAL PARAMETER => identifier = > 

=> string literal = > 
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(12.1) (parserl) 

GENERIC FORMAL PART => procedure PROCEDURE_UNIT 

=> function FUNCTION_UNIT 
=> package PACKAGE_DECLARATION 



(12.1) (parserl) 

GENERIC PARAMETER DECLARATION => IDENTIFIER LIST : [MODE ?] NAME 

[: = EXPRESSION ?] ; 

=*■ type private [DISCRIMINANT PART ?] 

is PRIVATE TYPE DECLARATION ; 

=> type private [DISCRIMINANT PART ?] 

is GENERIC TYPE DEFINITION ; 

=> with procedure PROCEDURE UNIT 

=> with function FUNCTION_UNIT 

(12.1) (parser2) 

GENERIC TYPE DEFINITION =»(<>) 

=> range < > 

=> digits < > 

=> delta < > 

=> array ARRAY TYPE DEFINITION 

=> access SUBTYPE_JNDICATlON 

(5.9) (parser3) 

GOTO STATEMENT => NAME ; 

(3.2) (parser2) 

IDENTIFIER DECLARATION ^IDENTIFIER LIST : IDENTIFIER DECLARATION TAIL 

(3.2) (parser2) 

IDENTIFIER DECLARATION TAIL =£ exception EXCEPTION_TAIL 

= > constant CONSTANT_TERM 

=> array ARRAY TYPE DEFINITION 

[: = EXPRESSION ?] ; 

=> NAME IDENTIFIER TAIL 

(3.2) (parser2) 

IDENTIFIER LIST => identifier [, identifier]* 

(3.2) (parser2) 

IDENTIFIER TAIL [CONSTRAINT ?][:= EXPRESSION ?] ; 

[renames NAME ?] ; 

(5.3) (parserl) 

IF STATEMENT => EXPRESSION then SEQUENCE OF STATEMENTS 

[elsif EXPRESSION then SEQUENCE OF STATEMENTS]* [else 

SEQUENCE OF STATEMENTS ?] end if ; 

(3.6) (parser3) 

INDEX CONSTRAINT =£ DISCRETE RANGE [, DISCRETE RANGE]*) 
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(3.5.4) (parser3) 

INTEGER TYPE DEFINITION => range RANGES 

(5.5) (parser3) 

ITERATION SCHEME => while EXPRESSION 

=* for LOOP PARAMETER SPECIFICATION 

(5.1) (parser2) 

LABELS << identifier > > 

(3.9) (parserl) 

LATER DECLARATIVE ITEM => PROPER BODY 

=> generic GENERIC DECLARATION 

=> use WITH OR USE CLAUSE 

(4.1) (parser3) 

LEFT PAREN NAME TAIL => [FORMAL PARAMETER ?] EXPRESSION [ EXPRESSION ?] 

[, [FORMAL PARAMETER ?] EXPRESSION 

[..EXPRESSION ?]]* ) [NAME TAIL]* 



(10.1) (parserO) 

LIBRARY UNIT =S> procedure PROCEDURE_UNIT 

=> function FUNCTlON_UNIT 
=> package PACKAGE_DECU\RATION 
=> generic GENERIC_DECLARATION 

(5.5) (parser3) 

LOOP PARAMETER SPECIFICATION => identifier in [reverse ?] DISCRETE RANGE 

(5.5) (parserl) 

LOOP STATEMENT => [ITERATION SCHEME ?] loop 

SEQUENCE OF STATEMENTS end loop [identifier ?] ; 

(6.1) (parser2) 

MODE => [in?] 

=> in out 
=> out 

(4.5) (parser4) 

MULTIPLYING OPERATOR * 

=> / 

=$ mod 
=> rem 

(4.1) (parser3) 

NAME => identifier [NAME TAIL?] 

=> character literalTNAME TAIL?] 

=> string literal [NAME TAIL ?] 
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(4.1) (parser3) 

NAM E TA|L => (LEFT P/XREN N/\ME TAJL 

=> SELECTOR [N A ME_T A IL]* 

=> ' A GGREG A TE [N A ME T/\IL]* 

=> ATTRIBUTE DESIGN A TOR [N/\ME TA.I L] * 

(7.1) (parserl) 

P/XCK/XGE DECLARATION body identifier is SUBPROG R A M BODY 

=> identifier is P/\CK A GE_T A IL_END 
=£ identifier renames NAME; 



(7.1) (parserl) 

P A CK A G E T/\l L E N D => new NAME (GENERIC A CTU A L P A RT ?] ; 

=> [BASIC_DECLARATIVE_ITEM]*Tprivate 

[BA.SIC DECLARATIVE ITEM]* ?] end [identifier ?] ; 



(6.1) (parser2) 

PARAMETER SPECIFICATION => IDENTIFIER LIST : MODE N A ME [: = EXPRESSION ?] 

(4.4) (parser3) 

PRIMARY => numeric literal 

=> null 

=> string literal 
=> new aTLOCATOR 
=* NAME 
=> AGGREGATE 

(7.4) (parser2) 

PRIVATE TYPE DECLARATION => [limited ?] private 

(6.1) (parserl) 

PROCEDURE UNIT => identifier [FORMAL_PART ?] is SUBPROGRAM_BODY 

=£ identifier [FORMAL PART ?] ; 

=£ identifier [FORMAL P A RT ?] renames NAME ; 

(3.9) (parserl) 

PROPER BODY => procedure PROCEDURE_UNIT 

^ function FUNCTION UNIT 
=> package PACKAGEjDECLARATION 
=> task TASK DECLARATION 

(3.5) (parser3) 

RANGES => SIMPLE EXPRESSION [,.SIMPLE_EXPRESSION ?] 

(11.3) (parser3) 

FLAISE STATEMENT => [NAME ?] ; 

(13.4) (parser2) 

RECORD REPRESENTATION CLAUSE ^ [at mod SIMPLE_EXPRESSION ?] 

[NAME at SIMPLE EXPRESSION range 

RANGES]*end record ; 
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(3.7) (parser2) 

RECORD TYPE DEFINITIONS COMPONENT_UST end record 

(4.4) (parser3) 

RELATION S SIMPLE_EXPRESSION [SlMPLE_EXPRESSION_TAIL ?] 

(4.4) (parser3) 

RELATION TAIL S [and [then ?] RELATION]* 

S [or [else?] RELATION]* 

S [xor RELATION]* 

(4.5) (parser4) 

RELATIONAL OPERATOR S = 

S / = 

S < 

=> < = 
s > 
s > = 

(13.1) (parser2) 

REPRESENTATION CLAUSE S for NAME use record 

RECORD REPRESENTATION CLAUSE 

S for NAME use [at?] SIMPLE EXPRESSION; 



(5.8) (parser3) 

RETURN STATEMENT S [EXPRESSION?], 

(9.7.1) (parserl) 

SELECT ALTERNATIVE S [when EXPRESSION = > ?] accept ACCEPT_STATEMENT 

[SEQUENCE OF STATEMENTS ?] 

S [when EXPRESSION = > ?] delay DELAY STATEMENT 

[SEQUENCE OF STATEMENTS ?] 

S [when EXPRESSION = > ?] terminate ; 

(9.7.1) (parserl) 

SELECT ENTRY CALL =» else SEQUENCE OF STATEMENTS 

=» or delay DELAY_STATEMENT 

[SEQUENCE OF STATEMENTS ?] 

(9.7) (parserl) 

SELECT STATEMENT =» select SELECT STATEMENT TAIL [ SELECT ENTRY CALL ?] 

end select ; 

(9.7.1) (parserl) 

SELECT STATEMENT TAIL SELECT ALTERNATIVE [or SELECT ALTERNATIVE]* 

=> NAME; [SEQUENCE OF STATEMENTS?] 



(4.1.3) (parser4) 

SELECTOR => identifier 

=$ character literal 
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=£ string literal 
=> all 

(5.1) (parserl) 

SEQUENCE OF STATEMENTS =* [STATEMENT] f 

(4.4) (parser3) 

SIMPLE EXPRESSION =>[+?] TERM [BINARY ADDING OPERATOR TERM]* 

=> [-?] TERM [BINARY ADDING OPERATOR TERM]* 



(4.4) (parser3) 

SIMPLE EXPRESSION TAIL =* RELATIONAL OPERATOR SIMPLE_EXPRESSlON 

=> [not?] in RANGES 
=* [not ?] in NAME 

(5.1) (parser2) 

SIMPLE STATEMENT => null ; 

=> ASSIGNMENT OR PROCEDURE CALL 

=> exit EXIT STATEMENT 

=> return RETURN_STATEMENT 

=> goto GOTO STATEMENT 

=> delay DELAY_STATEMENT 
abort ABORT_STATEMENT 
=* raise RAISE STATEMENT 

(5.1) (parserl) 

STATEMENT => [LABEL ?] SIMPLE STATEMENT 

[LABEL ?] COMPOUND STATEMENT 

(6.3) (parserl) 

SUBPROGRAM BODY =» new NAME [GENERIC ACTUAL PART ?] ; 

=$ separate ; 

=> < > ; 

=* [DECLARATIVE PART ?] [begin SEQUENCE OF STATEMENTS 

[exception [EXCEPTION HANDLER] * ?]?] end [DESIGNATOR ?] ; 

=> NAME; 

(3.3.2) (parser2) 

SUBTYPE DECLARATION =£ identifier is SUBTYPE_INDICATION ; 

(3.3.2) (parser3) 

SUBTYPE INDICATION => NAME [CONSTRAINT ?] 

(10.1) (parserO) 

SUBUNIT separate (NAME) PROPER BODY 

(9.1) (parserl) 

TASK DECLARATION =* body identifier is SUBPROGRAM_BODY ; 

[type ?] identifier [is [ENTRY DECLARATION]* 

[REPRESENTATION CLAUSE]* end [identifier ?] ">] ; 
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(4,4) (parser3) 

TERM => FACTOR [MULTIPLYING OPERATOR FACTOR]* 

(3.3.1) (parser2) 

TYPE DECLARATION =» identifier [DISCRIMINANT_PART ?] 

[is PRIVATE TYPE DECLARATION ?] ; 

=* identifier [DISCRIMINANT_PART ?] 

[is TYPE DEFINITION ?] ; 

(3.3.1) (parser2) 

TYPE DEFINITION =* ENUMERATION TYPE DEFINITION 

=> INTEGER TYPE DEFINITION 

=> digits FLOATING OR FIXED POINT CONSTRAINT 

=> delta FLOATING OR FIXED POINT CONSTRAINT 

=* array ARRAY TYPE DEFINITION 

=> record RECORD TYPE DEFINITION 

=*> access SUBTYPE_INDICATION 
=* new SUBTYPE INDICATION 

(3.7.3) (parser2) 

VARIANT when CHOICE [| CHOICE]* = > COMPONENT_LIST 

(3.7.3) (parser2) 

VARIANT PART =$ case identifier is [VARIANT] * end case ; 

(10.1.1) (parser2) 

WITH OR USE CLAUSE =£ identifier [, identifier]* ; 
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APPENDIX B 



"ADAFLOW” PROGRAM LISTING - MAIN 



TITLE; 


ADAFLOW 


-- 


MODULE NAME: 


PROCEDURE MAIN 


__ 


FILE NAME: 


MAIN. ADA 


-- 


DATE CREATED: 


02 


FEB 88 


-- 


LAST MODIFIED: 


28 


APR 88 


-- 


AUTHOR ( S ) : 


LT 


ALBERT J. GRECCO, 


USN 


DESCRIPTION: 


This 


procedure is the 


highest level procedure -- 



of ADAFLOW. It queries the user for an ADA 
program to model, sets up the token matcher, 
starts the parser through the ADA program, and -- 
translates the results of the parse to P-NUT 
code. 



with TOKEN_MATCHER, CODE_BLOCKER , SYMBOL_TABLE , 
NET_GENERATOR, PARSER, TEXT_IO; 



procedure MAIN is 

SOURCE_CODE_F I LE : string (1..80) := (others => ' * ); 
SOURCE_CODE_F ILE_LENGTH : natural; 



procedure GET_FILE_NAME is 
UNKNOWN_NAME : exception; 
use TEX T_1 0 ; 
begin 

put_l i ne( "WELCOME TO ADAFLOW"); newline; 

put_line( "ENTER THE NAME OF AN ADA SOURCE FILE TO MODEL"); new_line; 
SOURCE_CODE_FILE := (others => ' '); 

get_line(SOURCE_CODE_FILE, SOURCE_CODE_FILE_LENGTH ) ; new_line; 
if (SOURCE_CODE_FILE_LENGTH = 0) then 
raise UNKNOWN_NAME ; 
else 

p u t_l ine(SOURCE_CODE_FILE( 1. .SOURCE CODE_F I LEJ.ENGTH)); 
end if; 

end GETFILENAME; 
beg i n 
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GET_FILE_NAME; 

TOKEN_MATCHER.SET_UP_TOKEN_MATCHER(SOURCE_CODE_FILE( 1. . 

SOURCE_CODE_F I LE_LENGTH ) ) ; 

TEXT_IO . put_l ine( "PARSING BEGINS ..."); 
if PARSER. IS_PARSED then 

TEXT_IO.put_line(" . . . PARSE SUCCESSFUL"); 

NET_GENERATOR . TRANSLATE_TO_PEANUT ; 
el se 

TEXT_IO . put_l ine(". . . PARSE UNSUCCESSFUL"); 
CODE_BLOCKER.CLEAR_CODE_BLOCKER; 

NET_GENERATOR . RESET_NET_GENERATOR ; 
end if; 

SYMBOL_TABLE . CLEAR_SYM_TAB ; 

TOKEN_MATCHER.RELEASE_TOKEN_MATCHER; 

exception 

when others => 

TEXT_IO.put_line("UNABLE TO MODEL ADA SOURCE CODE"); 

TEXT_IO.put_line(". . . PARSE UNSUCCESSFUL"); 
CODE_BLOCKER.CLEAR_CODE_BLOCKER; 

NET_GENERATOR.RESET_NET_GENERATOR; 

SYMBOL_TABLE .CLEAR_SYM_TAB ; 
begin 

TOKEN_MATCHER . RELEASE_TOKEN_MATCHER ; 
exception 

when others => null; 
end ; 

end MAIN; 
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APPENDIX C 



"ADAKI.OW” PROGRAM LISTING - PARSKK 



TITLE: 


ADAFLOW 


-- 


MODULE NAME: 


PACKAGE PARSER 


-- 


FILE NAME: 


PARSER. ADS 


-- 


DATE CREATED: 


18 FEB 88 


-- 


LAST MODIFIED: 


28 APR 88 


-- 


AUTHOR(S) : 


LT ALBERT J. GRECCO, USN 


- 


DESCRIPTION: 


This package defines the only interfaces to 


— 



to the parser. Packages PARSERO through PARSER_4 
exist only as local packages to package PARSER and are 
not user accessable. 



package PARSER is 

function IS_PARSED return boolean; 

-- pre - TOKENJ1ATCHER, SYMBOt_TABLE , C0DE_B10CKER , and NET_GENERATOR are 
initialized. 

-- post - If the file being parsed is a valid ADA program, IS_PARSED 
is TRUE else IS_PARSED is FALSE. 

end PARSER; 



59 



TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE PARSER 

-- FILE NAME: PARSER. ADB 



-- DATE CREATED: 18 FEB 88 

-- LAST MODIFIED: 28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package implements the only interfaces to -- 

the parser. 



*«*«•**•*****•__ 



with PARSERJ), PARSER4 ; 

package body PARSER is 

function ISPARSED return boolean is 

-- pre - TOKENJ4ATCHER, SYMBOL_TABLE , CODE_BLOCKER, and NET_GENERATOR have 
been initialized. 

-- post - If the file being parsed is a valid ADA program, IS_PARSED 
is TRUE else IS_PARSED is FALSE. 

beg i n 

return PARSERJ) .COMPILATION ; 
exception 

when PARSER4 . PARSERERROR => 
return FALSE; 
when others => 
raise ; 

end I SPARSED ; 
end PARSER; 
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TITLE: 



ADAFLOW 



MODULE NAME: 
FILE NAME: 

DATE CREATED: 
LAST MODIFIED: 



PACKAGE PARSER_0 
PARSERO .ADS 

18 FEB 88 
28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



-- DESCRIPTION: This package defines the functions that 

make up the highest level productions for a top-down, 
recursive descent parser. 



package PARSERO is 

function COMPILATION return boolean; 
function COMPILATIONJJNIT return boolean; 
function CONTEXT_CLAUSE return boolean; 
function BASIC_UNIT return boolean; 
function LIBRARYJJNIT return boolean; 
function SUBUNIT return boolean; 
end PARSE R_0 ; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: 

-- FILE NAME: 

-- DATE CREATED: 
-- LAST MODIFIED: 



PACKAGE PARSERO 
PARSERO .ADB 

18 FEB 88 
28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



-- DESCRIPTION: This package implements the functions that 

make up the highest level productions for a top-down, 
recursive descent parser. Each function is preceded 
by the grammar productions they are implementing. 



with PARSER_1 , PARSER_2 , PARSER_3, PARSER_4, TOKENMATCHER ; 

package body PARSER_0 is 

package TM renames TOKEN_MATCHER ; 
package PI renames PARSERl; 
package P2 renames PARSERS; 
package P3 renames PARSER_3; 
package P4 renames PARSER_4; 

-- COMPILATION --> [COMPI LATION_UNI T]+ 
function COMPILATION return boolean is 
beg i n 

if ( P4 . PRI NT_CALLS ) then 
P4 . OUT_PUT ( "COMPILATION" ) ; 
end if; 

if ( COMPILAT ION_UNIT ) then 

while (COMPILATIONJJNIT) loop 
null ; 
end loop; 
return (TRUE); 
else 

return (FALSE); 
end if; 

end COMPILATION; 
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-- COMP I LA T ION UN I T — > CONTEXT_CLAUSE BASICJJNIT 

function COMPILATIONJJNIT return boolean is 
begin 

if ( P 4 . PRINT_CALLS ) then 

P4 .0UT_PUT ( "COMPILATION_UNIT" ) ; 
end if; 

if (CONTEXTCLAUSE) then 
if (BASIC_UNIT) then 
return (TRUE); 
e 1 se 

return (FALSE); 
end if; 
else 

return (FALSE); 
end if; 

end COMPILATIONJJNIT; 



-- CONTEXT_CLAUSE --> [with WITH_OR_USE_CLAUSE [use WITH_OR_USE_CLAUSE]* ]* 
function CONTEXT_CLAUSE return boolean is 
begin 

if (P4 ,PRINT_CALLS) then 

P4 .OUT_PUT ( "CONTEXT_CLAUSE" ) ; 
end if; 

while ( TM. MATCH (TM.TOKEN_WITFI) ) loop 
if not (P2.WITH_OR_USE_CLAUSE) then 
P4.SYNTAX_ERR0R( "Context clause"); 
end if; 

while ( TM . MATCH ( TM . TOKEN JJSE ) ) loop 
if not (P2.WITH_0R_USE_CLAUSE) then 
P 4 . SYNTAX_ERROR( "Context clause"); 
end if; 

end loop; -- inner while loop 

end loop; -- outer while loop 

return (TRUE); 
end CONTEXT_CLAUSE ; 



-- BASICJJNIT --> LIBRARY JJNIT 
--> SUBUNIT 

function BASIC_UNIT return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4 . OUT_PUT ( "BASIC_UNIT" ) ; 
end if; 

if (LIBRARYUNIT) then 
return (TRUE); 
el si f (SUBUNIT) then 
return (TRUE); 
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el se 

return (FALSE); 
end if; 

end BASIC_UN IT ; 



-- LIBRARYJJNIT --> 

--> 
— > 

function LIBRARYJJNIT 



procedure PROCEDURE_UNIT 
function FUNCTION JJNIT 
package PACKAGE_DECLARATION 
generic GENERIC_DECLARATION 
return boolean is 



beg i n 

if (P4.PRINT_CALLS) then 
P4 ,0UT_PUT ( "LIBRARY_UNIT" ) ; 
end if; 



if ( TM. MATCH ( TM. lo»v . PROCEDURE)) then 
if (Pl.PROCEDUREJJNIT) then 
return (TRUE); 
else 



P4 .SYNTAX_ERROR(" Library unit" ); 
end if; -- if procedureuni t statement 
elSif ( TM .MATCH ( TM „ TOKEN_F UNCTION ) ) then 
if ( PI . FUNCTIONJJNIT) then 
return (TRUE); 
else 



P4.SYNTAX_ERR0R( "Library unit" ) ; 
end if; -- if function_unit statement 
elsif ( TM . MATCH ( TM . TOKEN_PACKAGE ) ) then 
if (Pl.PACKAGEJDECLARATION) then 
return (TRUE); 
else 



P4.SYNTAX_ERROR(" Library unit") ; 
end if; -- if package_declaration 
elsif ( TM .MATCH( TM . TOKEN JJENERIC ) ) then 
if ( Pi .GENE RIC_DECLARAT ION ) then 
return (TRUE); 
el se 



P4.SYNTAX_ERROR( "Library unit" ) ; 
end if; -- if generi c_decl aration 
else 



return (FALSE); 
end if; 

end LIBRARYJJNIT; 



SUBUNIT --> separate (NAME) PROPER_BODY 
function SUBUNIT return boolean is 
beg i n 

if (P4. PRINT CALLS) then 
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P4.0UT_PUT( "SUBUNIT" ); 
end If; 

if (TM.MATCH(TM. TOKEN_SEPARATE ) ) then 
if ( TM .MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if ( P3 . NAME ) then 

if ( TM. MATCH ( TM. TOKEN_RIGHT_PAREN ) ) then 
if (PI. PROPER_BODY ) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Subunit" ) ; 
end if; — if proper_body statement 
else 

P4 . SYNT AX_ERROR( "Subunit") ; 
end if; -- if bypass( token_right_paren) 
el se 

P4 . SYNTAX_ERROR( "Subunit" ) ; 
end if; -- if name statement 
else 

P4 . SYNTAX_ERROR( "Subunit” ) ; 
end if; -- if bypass( token_lef t_paren) 
else 

return (FALSE); 

end if; -- if bypass( token_separate) 
end SUBUNIT; 

end PARSE R_0 ; 
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TITLE: 



ADAFLOW 



MODULE NAME: 
FILE NAME: 

DATE CREATED: 
LAST MODIFIED: 



PACKAGE PARSER_ 1 
PARSER1 .ADS 

18 FEB 88 
28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



— DESCRIPTION: This package defines the functions 

that make up the top level productions for a top-down 
recursive descent parser. 



package PARSER_1 is 

function GENERIC_DECLARATION return boolean; 

function GENERIC _PARAMETER_DECLARATION return boolean; 

function GENERIC_FORMAL_PART return boolean; 

function PROCEDURE_UNIT return boolean; 

function SUBPROGRAM_BODY return boolean; 

function FUNCTIONUN IT return boolean; 

function TASKDECLARATION return boolean; 

function PACKAGE_DECLARATION return boolean; 

function PACKAGE_TAIL_END return boolean; 

function DECLARATIVEPART return boolean; 

function BASIC_DECLARATIVE_ITEM return boolean; 

function BASIC_DECLARATION return boolean; 

function LATERDECLARATIVEITEM return boolean; 

function PROPERBODY return boolean; 

function SEQUENCE_OF_STATEMENTS return boolean; 

function STATEMENT return boolean; 

function COMPOUNDSTATEMENT return boolean; 

function BLOCK_STATEMENT return boolean; 

function IF_STATEMENT return boolean; 



function CASESTATEMENT return boolean; 
function CASESTATEMENTALTERNATI VE return boolean; 
function LOOPSTATEMENT return boolean; 
function EXCEPT IONHANDLER return boolean; 
function ACCEPT STATEMENT return boolean; 
function SELECT_STATEMENT return boolean; 
function SELECTSTATEMENT TAIL return boolean; 
function SELEC f_AL TERNAriVE return boolean; 
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function SELECT_ENTRY_CALL return boolean; 
end PARSER_1; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE PARSER_1 

-- FILE NAME: PARSERl . ADB 



— DATE CREATED: 18 FEB 88 

-- LAST MODIFIED: 28 APR 88 

-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



functions 



DESCRIPTION: This package implements the 

that make up the top level productions for a top-down 
recursive descent parser. Each function is preceded 
by the grammar productions they are implementing. 



with PARSER_2, PARSER_3, PARS£R_4, 

TOKEN_MATCHER , TOKEN_SCANNER , CODE_BLOCKER , 

SYMBOL_TABLE, NET_GENERATOR ; 

package body PARSERl is 

package TM renames TOKEN_MATCHER ; 
package P2 renames PARSER_2; 
package P3 renames PARSER3; 
package P4 renames PARSER4; 

I S_MA I N_P ROG RAM : boolean := TRUE; 

-- GENERIC_DECLARATION --> [GENERIC_PARAMETER_DECLARATION ] 
GENERIC_FORMAL_PART 

function GENERICDECLARATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "GENERIC_DECLARATION" ) ; 
end if; 

while (GENERIC_PARAMETER_DECLARATION) loop 
null ; 
end loop; 

if ( GENE RIC_FORMAL_P ART ) then 
return( TRUE ) ; 
else 

return (FALSE); 
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end if; 

end GENERICJJECLARATION; 



-- GENERIC_PARAMETER_DECLARATION --> 

--> 



IDENTI FIER_LIST : [MODE ?] NAME 
[:» EXPRESSION ?] ; 
type private [DISCRIMINANT_PART ?] 



is PRIVATE_TYPE_DECLARATION ; 

--> type private [DISCRIMINANTPART ?] 
is GENERIC_TYPE_DEFINITI0N ; 

--> with procedure PROCEDUREJJNI T 
--> with function FUNCTIONJJNIT 
function GENERIC_PARAMETER_DECLARATION return boolean is 



begin 

if ( P4 . PRI NT_CALLS ) then 

P4 . OUT_PUT ( "GENERIC_PARAMETER_DECLARATION" ) ; 
end if; 

if ( P2 . IDENTI FIE R_L 1ST ) then 

if ( TM .MATCH ( TM . TOKENCOLON ) ) then 
if (P2.M0DE) then 
null; 



end if; -- if mode statement 

if ( P3 . NAME ) then — check for type_mark 
if ( TM .MATCH ( TM. TOKEN_ASSIGNMENT ) ) then 
if (P3. EXPRESSION) then 
null ; 



el se 



P4 .SYNTAX_ERROR( "Generic parameter declaration"); 

end if; -- if expression statement 

end if; -- if match( tokenassignment) 

if ( TM . MATCH { TM . TOKEN_SEMI COLON ) ) then 
return {TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if match( token_semicolon ) 

else 



P4 .SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if type_mark statement 

else 



P4 . SYNTAX_ERROR{ "Generic parameter declaration"); 
end if; -- if match( token_colon ) 

el si f ( TM . MATCH ( TM . TOKEN_TYPE ) ) then 

if ( TM .MATCH( TM . TOKEN IDENT I FI ER) ) then 
if (P2.DISCRIMINANTPART) then 
null; 

end if; -- if discriminant_part 

if (TM.MATCH(TM. TOKEN IS)) then 

if ( P2 . PRIVATE_TYPE_DECLARATION ) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 
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el se 

P4 ,SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if match( token_semi col on ) 

elsif (P2.GENERIC_TYPE_DEFINITI0N) then 
if (TM.MATCH(TM.TOKEN_SEMICOLON) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; — if match( token_semicol on ) 

else 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; — if private_type_declaration 

el se 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; — if match( token_i s ) 

else 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; — if match( token_identif ier) 

elsif ( TM .MATCH ( TM . TOKEN_WITH ) ) then 
if ( TM .MATCH ( TM . TOKEN_PROCEDURE ) ) then 
if ( PROCEDURE_UNI T ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic parameter declaration"); 
end if; — if procedure_uni t statement 

elsif ( TM. MATCH (TM.T0KEN_F UNCTION) ) then 
if ( FUNCTION JJNIT) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic parameter declaration”); 
end if; — if f unction_unit statement 

else 

P4 . SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if match( token_procedure ) 

else 

return (FALSE); 

end if; -- if identi f ier_l ist 

end GENERIC_PARAMETER_DECLARAT ION ; 



-- GENERIC_FORMAL_PART --> procedure PR0CEDURE_UNI T 
--> function FUNCTION_UNI T 
--> package PACKAGEDECLARATION 
function GENERIC_FORMAL_PART return boolean is 
beg i n 

if (P4.PRINTCALLS) then 

P4 .OUT PUT ( "GENERIC_FORMAL PART" ) ; 
end 1 f ; 

if ( fM.MATCH(TM. TOKEN PROCEDURE)) then 
if (PROCEDUREUNIT) then 
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return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic formal part"); 
end if; -- if procedure_unit statement 

elsif (TM.MATCH(TM. TOKEN_FUNCTION ) ) then 
if (FUNCTIONUNIT) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic formal part"); 
end if; -- if function_unit statement 

elsif ( TM .MATCH ( TM . TOKEN_PACKAGE ) ) then 
if (PACKAGE_DECLARATION) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic formal part"); 
end if; -- if package_decl aration 

else 

return (FALSE); 
end if; 

end GENERIC_FORMAL_PART ; 



-- PROCEDURE_UNIT --> identifier [FORMAL_PART ?] is SUBPROGRAM_BODY 
--> identifier [FORMAL_PART ?] ; 

--> identifier [FORMALPART ?] renames NAME ; 
function PROCEDURE_UNIT return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION : natural ; 
begin 

if ( P4 . PRINT_CALLS) then 

P4 .OUT_PUT ( "PROCEDURE_UNIT" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_IDENTI F I E R ) ) then 
TM .MATCHED_TOKEN( START_TOKEN ) ; 

CODE_B LOCKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "PROCEDURE CODE BLOCK"); 
CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCATION ;= CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

SYMBOL TABLE . I NSE RT_SYM_TAB ( STARTTOKEN . LEXEME ( 1 . . START_TOKEN . LEXEME SIZE ) , 
SYMBOL_TABLE.PROCEDURE_DECLARATION_TAG, 
LOCATION); 

SYMBQL_TABLE . INSERT_SYM_TAB( "END" , SYMBOL_TABLE . LABELNAME , 0); 
if ( I S_MA I N_PR0GRAM ) then 

NET_GENERATOR . STAR T ( SYMB0L_T ABLE . FIND_KEY ( STARTTOKEN . LEXEME ( 1 . . 

START_TOKEN . LEXEMESI ZE ) ) ) ; 

IS_MAIN_PR0GRAM := FALSE; 
end if; 

if ( P2 . FORMA LPART ) then 
null ; 

end if; -- if formal part statement 

if (TM.MATCH( TM. TOKEN IS)) then 
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if (SUBPROGRAM_BODY) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Procedure unit" ); 

end if; -- if subprogram body statement 

el si f ( TM . MATCH ( TM . T0KEN_SEMI COLON ) ) then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE . EXI T^SCOPE ; 

SYMB0L_T ABLE . UPDATE_SYM_TAB( 0 ) ; 
return (TRUE); 

el si f ( TM . MATCH ( TM . TOKEN_RENAMES) ) then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE . EXIT_SCOPE ; 

SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
if (P3.NAME) then 

if ( TM .MATCH ( TM. TOKEN_SEMI COLON ) ) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Procedure unit"); 
end if; -- if match( token_semi colon ) 

else 

P4.SYNTAX_ERROR( "Procedure unit" ) ; 
end if; -- if name statement 

end if; -- if match( token_i s ) 

else 

return (FALSE); 

end if; -- if match(token_identif ier) 

end PR0CEDURE_UNI T ; 



-- SUBPROGRAM_BODY --> new NAME [GENERIC_ACTUAL _PART ?] ; 

--> separate ; 

--> <> ; 

--> [DECLARATIVE_PART ?] [begin SEQUENCE_OF_STATEMENTS 
[exception [EXCEPT I ON_HANDLER]+ ?]?] end [DESIGNATOR ?] ; 
--> NAME ; 

function SUBPROGRAMBODY return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

ST0P_T0KEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATIONONE : natural; 

LOCATIONTWO : natural; 
use SYMBOL_TABLE ; 
begin 

if (P4.PRINTCALLS) then 

P4 . OUT_PUT ( " SUBPROGRAM_BODY " ) ; 
end if; 

LOCATION ONE := CODEBLOCKER .CURRENTCODEBLOCKNUMBER ; 
if ( TM.MATCH(TM. TOKEN_NEW) ) then 

CODE BLOCKER. DELETE_CODE_BLOCK_ENTER ; 

SYMBOLTABLE .EXITSCOPE ; 
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SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
if ( P3 . NAME ) then 

if (P2.GENERIC_ACTUAL_PART) then 
null; 

end if; -- if generic actual part 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
return (TRUE); 
else 



P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if match( token_semicol on ) 

else 



P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if name statement 

elsif ( TM .MATCH( TM . TOKEN_SEPARATE ) ) then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE.EXIT_SCOPE; 

SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
if ( TM. MATCH (TM.TOKEN_SEM I COLON) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if match( token_semicolon) 

elsif ( TM . MATCH ( TM . TOKEN_BRACKETS ) ) then 
COOE_BLOCKER . DELETE_CODE_BLOCK_ENTER ; 

SYMB0L_TABLE.EXIT_SC0PE; 

SYMBOL _TABLE . UPDATE_SYM_TAB( 0 ) ; 
if ( TM. MATCH (TM.TOKEN_SEM I COLON) ) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R( "Subprogram body" ) ; 
end if; -- if match( token_semicol on ) 

elsif (DECLARATIVE_PART) then 

LOCATIONONE := CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
if ( TM .MATCH ( TM . TOKEN_BEGIN ) ) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 

CODE_BLOCKER.ENTER_CODE_BLOCK(START_TOKEN. SOURCE, "BEGIN SUBPROGRAM"); 
C0DE_BL0CKER . I NCREMENT__STATEMENT_COUNT ; 

L0CATI0N_TW0 := C0DE_BL0CKER .CURRENT_CODE_BLOCK_NUMBER; 

NET_GENERATOR . CONNECT_BLOCKS( LOCATION_ONE , LOCATION_TWO ) ; 
if (SEQUENCE_OF_STATEMENTS) then 

if (CODEB LOCKER . CURRENT_STATEMENT_COUNT = 0) then 
LOCATIONONE := 0; 

C0DE_BL0CKER . DELETE_CODE_BLOCK_ENTER ; 
else 



TM.MATCHED_TOKEN(STOP_TOKEN) ; 

L0CATI0N_0NE := CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
CODE_BLOCKER . EXIT_CODE_BLOCK( STOPTOKEN . SOURCE ) ; 
end if; 

if (TM.MATCH(TM. TOKEN_EXCEPT ION ) ) then 
if ( EXCEPT I ONHANDLER ) then 
while ( EXCEPT I ON_HANDLER) loop 
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null; 
end loop; 
else 

P4 . SYNTAX_ERROR( "Subprogram body” ) ; 
end if; -- if exception_handler statement 

end if; -- if match( token_exception ) 

else 

P4. SYNTAX _ERROR( "Subprogram body") ; 
end if; -- if sequence of statements 

end if; -- if token begin 

if ( TM . MATCH ( TM . T0KEN_EN0) ) then 
TM.MATCHEO_TOKEN(STOP_TOKEN); 

CODE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , "END SUBPROGRAM") ; 
CODE_BLOCKER . INCREMENT_STATEMENT_C0UNT ; 

L0CATI0N_TW0 := C00E_BL0CKER . CURRENT_COOE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . F INO_LOCAL_KEY( "ENO" ) = null) then 
raise SYMBOL_TABLE . REFERENCEERROR; 
else 

SYMBOL_TABLE . UPDATE_SYM_TAB( LOCATION_TWO ) ; 
end if; 

if (LOCATIONONE = 0) then 

NET_GENERATOR.EXPLICIT_END(LOCATION_TWO) ; 
else 

NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, L0CATI0N_TW0 ) ; 
end if; 

CODE_BLOCKER . EXI T_CODE_BLOCK(STOP_TOKEN . SOURCE ) ; 
if ( 92 . DESIGNATOR) then 
null ; 

end if; -- if designator statement 

if ( TM .MATCH ( TM . T0KEN_SEMIC0L0N ) ) then 

CODE_BLOCKER . EXI T_CODE_BLOCK( ST0P_T0KEN . SOURCE ) ; 

SYMBOL_TABLE . EXIT_SCOPE ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if match( token_semicolon) 

else 

P4.SYNTAX_ERR0R( "Subprogram body"); 
end if; -- if match( token_end ) 

el si f ( TM .MATCH ( TM . TOKEN_BEGIN ) ) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 

LOCAT ION_ONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

C0DE_BL0CKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "BEGIN SUBPROGRAM" ) ; 
LOCATIONTWO : = C0DE_BL0CKER . CURRENT_COOE_BLOCK_NUMBER ; 
NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_TWO ) ; 
if ( SEQUENCE_OF_STATEMENTS) then 

if (CODEBLOCKER.CURRENTSTATEMENTCOUNT = 0) then 
LOCATIONONE := 0; 

CODE BLOCKER . DELETE_CODE_BLOCK_ENTER ; 
else 

TM.MATCHED_TOKEN(STOP_TOKEN) ; 
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LOCAT I ON_ONE := CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOC KER . EX I T_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_EXCEPTION ) ) then 
if ( EXCEPTIONHANDLER ) then 
while ( EXCEPT I ON_HANDLER ) loop 
null ; 
end loop; 
else 

P4.SYNTAX_ERR0R( "Subprogram body"); 
end if; -- if exception_handl er statement 

end if; -- if match( token_exception ) 

else 

P4 . SYNTAX_ERROR{ "Subp rog ram body"); 
end if; -- if sequence of statements 

if ( TM .MATCH ( TM . T0KEN_END) ) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

CODE_BLOCKER . ENTER_CODE_BLOCK ( STOP_TOKEN . SOURCE , "END SUBPROGRAM"); 
CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCATION_TWO := C0DE_B LOCKER .CURRENT_CODE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . FIND_LOCAL_KEY( "END" ) = null) then 
ra i se SYMBOL_TABLE . REFERENCE_ERROR ; 
else 

SYMBOL_TABLE.UPDATE_SYM_TAB(LOCATION_TWO); 
end if; 

if { LOCATION_ONE = 0) then 

NET_GENERATOR . EXPLICI T_END( LOCATION_TWO) ; 
else 

NET_GENERATOR . CONNECT_BLOCKS( LOCATIONONE , LOCATION_TWO) ; 
end if; 

CODE_BLOCKER . EXIT_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 
if (P2. DESIGNATOR) then 
null ; 

end if; -- if designator statement 

if ( TM . MATCH ( TM . TOKEN_SEMlCOLON ) ) then 
CODE_BLOCKER . EX I T_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 

SYMB0L_TABIE . EXI T_SCOPE ; 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Subprogram body " ) ; 
end if; -- if match( token_semicol on ) 

el se 

P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if match( token_end ) 

elsif (TM.MATCH(TM.TOKEN_END)) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE, "END SUBPROGRAM”); 
CODEBLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCAT ION_TWO : = CODE BLOCK ER . CUR REN T_CODE_BLOC K_NUMBER ; 
if ( SYMBOL TABLE . FIND_LOCAL_KEY( "END" ) = null) then 
raise SYMBOL_TABLt . REFERENCE_ERROR ; 
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else 

SYMBOL_TABLE.UPDATE_SYM_TAB(LOCATION_TWO) ; 
end if; 

NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCAT ION_TWO ) ; 
CODE_BLOCKER . EX I T_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 
if (P2. DESIGNATOR) then 
null; 

end if; -- if designator statement 

if (TM .MATCH ( TM . TOKENSEMICOLON ) ) then 

CODE_BLOCKER . EXI T_C0DE_BL0CK( STOP_TOKEN . SOURCE ) ; 

SYMBOL_TABLE . EXIT_SCOPE ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Subprogram body" ) ; 
end if; -- if match( token_semicolon) 

elsif ( P3 . NAME ) then 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE . EXI T_SCOPE ; 

SYMBOL_TABLE.UPDATE_SYM_TAB(0); 
if ( TM .MATCH ( TM. TOKEN_SE MI COLON ) ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Subprogram body" ) ; 
end if; — if match( token_semicolon ) 

else 

return (FALSE); 

end if; -- if match( tokennew) 

end SUBPROGRAM_BODY ; 



-- FUNCT ION_UNI T --> DESIGNATOR [ FORMAL_PART ?] return NAME is 

SUBPROGRAM_BODY 

--> DESIGNATOR [FORMAL_PART ?] return NAME ; 

--> DESIGNATOR [FORMAL_PART ?] return NAME renames NAME ; 
--> DESIGNATOR is SUBPROGRAMBODY 
(for generic instantiation) 
function FUNCTION_UNIT return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION : natural; 
begin 

if (P4.PRINTCALLS) then 

P4.0UT_PUT( "FUNCT ION UNIT" ) ; 
end if; 

if (P2. DESIGNATOR) then 

TM.MATCHED_TOKEN(START_TOKEN) ; 

CODEBLOCKER . ENTER_CODE_BLOCK( START_TOKEN .SOURCE , "FUNCTION CODE BLOCK"); 
CODEBLOCKER. INCREMENT_STATEMENT_COUNT; 

LOCATION := CODE_BLOCKER. CURRENT_CODE_BLOCK_NUMBER; 

SYMBOLTABLE . INSERT SYM TAB( START_TOKEN . LEXEME ( 1 . . START TOKEN . LEXEME_SI ZE ) , 
SYMBOLTABLE. FUNCTION DECLARATION TAG, 
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LOCATION); 

SYMBOL_TABLE . INSERT_SYM_TAB( "END" , SYMBOL_TABLE . LABEL_NAME , 0 ) ; 
if ( IS_MAIN_PROGRAM ) then 

NET_GENERATOR.START(SYMBOL_TABLE .FIND_KEY(START_TOKEN.LEXEME( 1. . 

START_TOKEN . LEXEME _SIZE ) ) ) ; 

IS_MAlN_PROGRAM := FALSE; 
end if; 

if (P2.FORMAL_PART) then 

if ( TM .MATCH ( TM . TOKEN_RE TURN ) ) then 
if ( P3 . NAME ) then 

if ( TM .MATCH ( TM . TOKEN_IS) ) then 
if (SUBPROGRAMBODY) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Function unit" ) ; 
end if; 

elsif ( TM . MATCH( TM . TOKEN_SEMI COLON ) ) then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE .EXIT_SCOPE; 

SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
return (TRUE); 

elsif (TM.MATCH(TM.TOKENRENAMES)) then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE .EXIT_SCOPE ; 

SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
if (P3.NAME) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Function unit”); 
end if; 
else 

P4.SYNTAX_ERROR(" Function unit"); 
end if; 
else 

P4.SYNTAX_ERROR( "Function unit"); 
end if; 
else 

P4.SYNTAX_ERROR(” Function unit”); 
end if; 

elsif ( TM .MATCH ( TM . TOKENRETURN ) ) then 
if ( P3 . NAME ) then 

if ( TM . MATCH ( TM . TOKEN_I S) ) then 
if (SUBPROGRAMBODY) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Function unit"); 
end if; 

elsif (TM.MATCH(TM. TOKENSE MI COLON ) ) then 
CODE_BLOCKER . DELETE_CODE_BLOCK_ENTER; 

SYMBOLTABLE . INSERT SYM TAB( "END" , SYMBOLTABLE . LABEL NAME , 0 ) ; 
SYMBOLTABLE .EXITSCOPE ; 
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SYMBOL_TABLE . UPDATE_SYM_TAB( 0 ) ; 
return (TRUE); 

elsif (TM.MATCH(TM.TDKEN_RENAMES)) then 
COOE_B LOCKER . DELETE_CODE_BLOCK_ENTER ; 
SYMBOLTABLE . EXIT_SCOPE ; 

SYMBOL_TABLE . UPOATE_SYM_TAB( 0 ) ; 
if ( P3 . NAME ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR(" Function unit" ) ; 
end if; 
else 

P4.SYNTAX_ERRDR( "Function unit" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "Function unit"); 
end if; 
else 

P4 . SYNTAX_ERROR( "Function unit"); 
end if; 

elsif ( TM . MATCH ( TM . T0KEN_IS) ) then 
if ( SUBPROGRAM_BODY ) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R( "Function unit"); 
end if; 
else 

return (FALSE); 
end if; 

end FUNCTIONJJNIT; 



-- TASK_DECLARATION --> body identifier is SUBPROGRAM_BODY ; 

--> [type ?] identifier [is [ ENTRYDEC LARA T ION]* 

[ RE PRESEN TAT ION CLAUSE ]• end [identifier ?] ?] ; 
function TASKOECLARATIDN return boolean is 
STARTTOKEN : TOKEN_SCANNER . T0KEN_REC0R0_TYPE ; 

LOCATION : natural ; 
begin 

if (P4.PRINT_CALLS) then 

P 4 .OUTPUT ( "TASK_DECLARATION" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_TYPE ) ) then 
null ; 

end if; -- if match( token_type ) 

if (TM.MATCH(TM. TDKEN_BDDY ) ) then 

if (TM.MATCH(TM.TOKEN_IOENTIFIER) ) then 
TM.MATCHEO_TOKEN(START_TOKEN) ; 

CDDEBLDCKER. ENTER CODE BL0CK( STARTTOKEN . SOURCE, "TASK CODE BLOCK"); 
C0DE_BL0CKER . I NCREMENT STATEMENT COUNT ; 
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LOCATION := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

SYMBOL_TABLE . INSERT_SYM_TAB( START_TOKEN . LEXEME ( 1 . .START_TOKEN . 

LEXEME_SI ZE ) , SYMBOLTABLE . TASKBODYTAG , 
LOCATION) ; 

if ( TM . MATCH ( TM . TOKEN_IS) ) then 
if ( SUBPROGRAM_BODY ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Package dec 1 a rat ion" ) ; 
end if; -- if subprogram body 

else 

P4 . SYNTAX_ERROR( "Package declaration” ) ; 
end if; -- if token is 

else 

P4.SYNTAX_ERR0R( "Package declaration" ) ; 
end if; -- if token identifier 

el si f ( TM .MATCH ( TM . TOKEN_IDENTI FI ER ) ) then 
TM . MATCHED_TOKEN( START_TOKEN ) ; 

SYMBOL_TABLE . INSERT_SYM_TAB( START_TOKEN . LEXEME( 1 . ,START_TOKEN . 

LEXEME_SIZE ) , 

SYMBOL_TABLE . TASK_DECLARAT ION_TAG , 0 ) ; 
SYMBOL_TABLE.INSERT_SYM_TAB( "END", SYMBOL_TABLE . LABEL_NAME , 0); 
NET_GENERATOR . START ( SYMBOL_TABLE . FIND_KEY ( START_TOKEN .LEXEME ( 1 . . 

STARTTOKEN . LEXEMESI ZE ) ) ) ; 

if ( TM.MATCH( TM . TOKEN_IS) ) then 
while ( P2 . ENTRY_DECLARATION ) loop 
null ; 
end loop; 

while (P2.REPRESENTATION_CLAUSE) loop 
null ; 
end loop; 

if ( TM .MATCH ( TM . TOKEN_END) ) then 

if ( TM .MATCH( TM . T0KEN_I0ENTI FI ER ) ) then 
null ; 

end if; -- if match( token_ident if ier) 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
SYMBOL_TABLE . EX I T_SCOPE ; 
return (TRUE); 
el se 

P4 .SYNTAX_ERROR( "Task declaration”); 
end if; -- if match( token_semi col on ) 

else 

P4 . SYNTAX_ERROR( "Task declaration" ) ; 
end if; -- if match( token_end ) 

elsif ( TM . MATCH ( TM . TOKEN_SE MI COLON ) ) then 
SYMBOL_TABLE . EX IT_SCOPE ; 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Task declaration”); 
end if; -- if match( tokenis ) 

else 
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return (FALSE); 
end if; 

end TASKDECLARATION ; 



if match( tokenbody ) 



— PACKAGE_DECLARATION --> body identifier is SUBPROGRAMBODY 
--> identifier is PACKAGE_TAIL_END 
--> identifier renames NAME; 
function PACKAGEDECLARATION return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION ; natural; 
begin 

if (P4.PRINTCALLS) then 

P4 .OUT_PUT( "PACKAGE_DECLARATION" ) ; 
end if; 

if ( TM . MATCH ( TM . T0KEN_B0DY ) ) then 

if ( TM . MATCH ( TM . TOKENIDENTI FIER) ) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 

CODE_BLOCKER.ENTER_CODE_BLOCK(START_TOKEN. SOURCE, "PACKAGE CODE BLOCK"); 
C0DE_BL0CKER . INCREMENT_STATEMENT_COUNT ; 

LOCATION := C0DE_BL0CKER . CURRENT_CODE_BLOCK_NUMBER ; 

SYMBOLTABLE . INSERT_SYM_TAB( START_TOKEN . LEXEME( 1 . . START_TOKEN . 

LEXEME_SIZE ) , SYMBOL_TABLE . PACKAGE_BODY_TAG , 
LOCATION); 

if ( TM . MATCH ( TM . T0KEN_IS ) ) then 
if (SUBPROGRAMBODY) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package declaration"); 
end if; -- if subprogram body 

else 

P4 . SYNTAX_ERROR( "Package declaration" ) ; 
end if; -- if token is 

el se 

P4.SYNTAX_ERR0R( "Package declaration" ) ; 
end if; -- if token identifier 

elsif ( TM . MATCH ( TM. TOKEN_IDENTI F IER ) ) then 
TM.MATCHEDTOKEN(STARTTOKEN) ; 
if ( TM. MATCH (TM.TOKEN_IS) ) then 

SYMBOLTABLE . I NSERT_SYM_TAB( START_TOKEN . LEXEME* 1 . . STARTTOKEN . 

LEXEME_SIZE ) , 

SYMBOL_TABLE . PACKAGE_DECLARATION_TAG , 0 ) ; 
SYMBOLTABLE . INSERT_SYM_TAB( "END" , SYMBOL_TABLE . LABEL_NAME , 0 ) ; 
if (PACKAGE_TAIL_END) then 
return (TRUE); 
e 1 se 

P4 . SYNTAX_ERROR( "Package declaration"); 
end if; -- if package_tail_end 

elsif (TM.MATCH(TM. TOKEN RENAMES)) then 
if ( P3 . NAME ) then 
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if ( TM . MATCH ( TM . TOKEN_SE MI COLON ) ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Package declaration" ) ; 
end if; -- if 

else 

P4 . SYNTAX_ERROR( "Package declaration" ) ; 
end if; -- if 

else 

P4 . SYNTAX_ERROR{ "Package dec 1 a rat i on" ) ; 
end if; -- if 

else 

return (FALSE); 

end if; --if 

end PACKAGE_DECLARATION; 



token semicolon 



name 



token identifier 



match( token_package ) 



-- PACKAGE_TAIL_END --> new NAME [GENERIC_ACTUAL_PART ?] ; 

--> [BASIC_DECLARATIVE ITEM]* [private 

[BASIC_DECLARATIVE_ITEM]* ?] end [identifier ?] ; 
function PACKAGE_TAIL_END return boolean is 
beg in 

if (P4.PRINTCALLS) then 

P4 .OUT_PUT( "PACKAGE_TAIL_END" ) ; 
end if; 

if (TM.MATCH(TM.TOKEN_NEW) ) then 
if (P3.NAME) then 

if (P2.GENERIC_ACTUAL_PART) then 
null ; 

end if; -- if generi c_actual_part statement 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
SYMBOL_TABLE . EX I T_SCOPE ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package tail end"); 
end if; -- if match( token_sem i col on ) 

else 

P4.SYNTAX_ERR0R( "Package tail end"); 
end if; -- if name statement 

elsif ( BASIC_DECLARATIVE_I TEM) then 
while ( BASIC_DECLARATIVE_ITEM ) loop 
null ; 
end loop; 

if ( TM .MATCH ( TM . TOKEN_PRIVATE ) ) then 
while (BASIC_DECLARATIVE_ITEM) loop 
null ; 
end loop; 

end if; - if match( tokenpri vate) 

if ( 1M.MATCH( TM. TOKEN_END) ) then 

if (TM.MATCH(TM.TOKEN_ IDENTIFIER)) then 
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null ; 
end if; 

if (TM.MATCH(TM. TOKEN_SEMI COLON ) ) then 
SYMBOL_TABLE . EXIT_SCOPE ; 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Package tail end”); 
end if; -- if match( token_semicolon) 

else 

P4.SYNTAX_ERR0R( "Package tail end"); 
end if; -- if match( token_end ) 

elsif (TM.MATCH(TM.TOKEN_PRIVATE) ) then 
while (BASIC_DECLARATIVE_ITEM) loop 
null ; 
end loop; 

if ( TM .MATCH ( TM . TOKEN_END) ) then 

if (TM.MATCH(TM.TOKEN_IDENTIFIER) ) then 
null ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_SE MI COLON ) ) then 
SYMBOL_TABLE . EXI T_SCOPE ; 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Package tail end"); 
end if; — if match( tokensemicolon ) 

else 

P4 . SYNTAX_ERROR( "Package tail end"); 
end if; -- if match( token_end ) 

elsif ( TM .MATCH ( TM. TOKEN_END) ) then 

if (TM.MATCH(TM.TOKEN_IDENTIFIER) ) then 
null; 
end if; 

if ( TM .MATCH ( TM . TOKEN_SE MI COLON ) ) then 
SYMBOL_TABLE . EXI T_SCOPE ; 
return (TRUE); 
else 

P4 ,SYNTAX_ERROR( "Package tail end"); 
end if; -- if match( tokensemicol on ) 

el se 

return (FALSE); 

end if; -- if match( tokennew ) 

end PACKAGETAILENO; 



-- BASIC_DECLARATIVE_I TEM --> BASIC_DECLARATI VE 

--> REPRESENTATION_CLAUSE 
--> use WI TH_OR_USE_CLAUSE 
function BASIC DECLARATIVE! TEM return boolean is 
begin 

if ( P4 . PR l N TCAL LS ) then 
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P4 .OUT_PUT { "BASIC_DECLARATI VE_ITEM” ) ; 
end if; 

if (BASIC_DECLARATION ) then 
return (TRUE); 

elsif (P2 .REPRESENTATIONCLAUSE) then 
return (TRUE); 

elsif { TM . MATCH ( TM . TOKEN_USE ) ) then 
if (P2.WITH_OR_USE_CLAUSE) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Bas ic declarative item”); 
end if; 
else 

return (FALSE); 
end if; 

end BASIC_DECLARATIVE_ITEM ; 



-- DECLARATIVE_PART--> [BASIC_DECLARATIVE_ITEM]* [LATER_DECLARATIVE_ITEM]* 
function DECLARATIVE_PART return boolean is 
begin 

if (P4.PRINTJIALLS) then 

P4 .OUT_PUT ( "DECLARATIVE_PART" ) ; 
end if; 

while (BASIC_DECLARATIVE_ITEM) loop 
null ; 
end loop; 

while (LATER_DECLARATIVE_ITEM) loop 
null; 
end loop; 
return (TRUE); 
end DECLARATIVE_PART ; 



-- BASIC_DECLARATION --> 
--> 
— > 
--> 
--> 
--> 

--> 

function BASIC_DECLARATION 
beg in 



type TYPE_DECLARATION 
subtype SUBTYPE_DECLARATION 
procedure PROCEDURE_UNIT 
function FUNCTI0N_UNIT 
package PACKAGE_DECLARATION 
generic GENERIC_DECLARATION 
IDENTI F IER_DECLARATION 
task TASK_DECLARATION 
return boolean is 



if (P4.PRINTCALLS) then 

P4 ,OUT_PUT( "BASIC_DECLARATION" ) ; 
end if; 

if ( rM.MATCH(TM. TOKEN TYPE)) then 
if ( P2 . TYPEDECLARAT ION ) then 
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return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Basic declaration"); 
end if; 

elsif { TM. MATCH (TM.TOKEN_SUB TYPE) ) then 
if (P2.SUBTYPE_DECLARATI0N) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Basic declaration" ) ; 
end if; 

elsif ( TM . MATCH ( TM . TQKEN_PROCEDURE ) ) then 
if (PROCEDUREJJNIT) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R( "Basic declaration"); 
end if; 

elsif (TM. MATCH (TM.TOKEN_FUNCT ION) ) then 
if (FUNCTIONJJNIT) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Basic declaration" ) ; 
end if; 

elsif ( TM . MATCH ( TM . TOKEN_PACKAGE ) ) then 
if (PACKAGE_DECLARATION) then 
return (TRUE); 
else 

P4 SYNTAX_ERROR( "Basic declaration"); 
end if; 

elsif ( TM .MATCH ( TM . T0KEN_GENERIC ) ) then 
if (GENERIC_DECLARATION ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Basic declaration") ; 
end if; 

elsif ( P2 . IDENTI FIER_DECLARATION ) then 
return (TRUE); 

elsif ( TM. MATCH ( TM. TOKEN_TASK) ) then 
if (TASK_DECLARATION) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Basic declaration” ) ; 
end if; 

else 

return (FALSE); 

end if; 

end BASIC_DECLARATION; 



if procedure_uni t statement 



if f unction_unit statement 



if package_decl aration 



if generic_decl aration 



LATERDECLARATIVE ITEM -> PROPER BODY 

-> generic GENERIC ^DECLARATION 
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— > use WITH_OR_USE_CLAUSE 
function LATER_DECLARATIVE_ITEM return boolean is 
beg in 

if ( P4 . PRI NT_CALLS ) then 

P4 . 0UT_PUT( " LATER_DECLARATIVE_I TEM" ) ; 
end if; 



if ( PR0PER_B0DY ) then -- check for body_declarat ion 

return (TRUE); 

elsif ( TM . MATCH ( TM . TOKEN_GENERIC ) ) then 
if ( GE NE RIC_DEC LARA T ION ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Later declarative item"); 
end if; -- if generi c_decl aration 

elsif ( TM .MATCH ( TM . TOKEN_USE ) ) then 
if (P2.WITH_0R_USE_CLAUSE) then 
return (TRUE); 
else 



P4.SYNTAX_ERROR( "Later declarative 
end if; 
else 



item" ) ; 

-- if with_or_use_clause 



return (FALSE); 
end if; 

end LATER_DECLARATIVE_ITEM; 



-- PR0PER_B0DY --> 
--> 
--> 



procedure PROCEDURE_UNI T 
function FUNCTIONUNI T 
package PACKAGEOECLARATION 
task TASK_DEC LARA T ION 



function PROPER_BOOY return boolean is 



begin 

if (P4.PRINT_CALLS) then 
P4.0UT_PUT("PR0PER_B0DY" ) ; 
end if; 



if ( TM . MATCH ( TM . TOKEN_PROCEDURE ) ) then 
if (PROCEDUREJJNIT) then 
return (TRUE); 
else 



P4 . SYNTAX_ERROR( "Proper body” ); 

end if; -- if procedure_un it statement 

elsif ( TM . MATCH ( TM . T0KEN_FUNCTI0N ) ) then 
if (FUNCTIONUNIT) then 
return (TRUE); 
el se 



P4. SYNTAX ERR0R( "Proper body" ) ; 

end if; -- if f unction_unit statement 

elsif ( TM .MATCH ( TM . TOKEN PACK AGE ) ) then 
if (PACKAGE_DECLARATION) then 
return (TRUE); 
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else 

P4 . SYNTAX_ERROR( "Proper body"); 
end if; -- if 

elsif ( TM . MATCH ( TM . TOKEN_TASK ) ) then 
if ( TASK_DECLARATION) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R( "Proper body"); 
end if; 
else 

return (FALSE); 

end i f ; --if 

end PROPER_BODY; 



-- SEQUENCE_OF_STATEMENTS — > [STATEMENT]+ 
function SEQUENCEOFSTATEMENTS return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT( "SEQUENCE_OF_STATEMENTS" ) ; 
end if; 

if (STATEMENT) then 

while (STATEMENT) loop 
null; 
end loop; 
return (TRUE); 
el se 

return (FALSE); 
end if; 

end SEQUENCE_OF_STATEMENTS ; 



— STATEMENT — > [LABEL ?] SIMPLE_STATEMENT 

--> [LABEL ?] COMPOUNO_STATEMENT 
function STATEMENT return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 
P4.0UT_PUT( "STATEMENT"); 
end if; 

if (P2. LABEL) then 
null; 
end if; 

if (P2.SIMPLE_STATEMENT) then 
return (TRUE); 

elsif ( COMPOUND_STATEMENT ) then 
return (TRUE); 
else 

return (FALSE); 



package_declaration 



match ( token_procedure) 
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end if; 

end STATEMENT; 



-- COMPOUND 


STATEMENT --> 


if I F_STATEMENT 


— 


— > 


case CASE_STATEMENT 


-- 


--> 


LOOP_STATEMENT 


— 


--> 


BLQCK_STATEMENT 


— 


--> 


accept ACCEPT_STATEMENT 


— 


— > 


SELECT_STATEMENT 


function COMPOUND_STATEMENT 


return boolean is 


START_TOKEN 


: TQKEN_SCANNER 


. TOKEN_RECORD_TYPE ; 



LOCATION_ONE : positive; 

L0CATI0N_TW0 : positive; 
use SYMBOL_TABLE; 
begin 

if ( P4 . PRI NT_CALLS ) then 

P4 . QUT_PUT ( "COMPOUND_STATEMENT" ) ; 
end if; 

if ( TM. MATCH (TM.TOKEN_IF) ) then 
if ( I F_STATEMENT ) then 

CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Compound statement” ) ; 
end if; -- if if_statement 

elsif ( TM .MATCH ( TM . TOKEN_CASE ) ) then 
if (CASE_STATEMENT ) then 

CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Compound statement" ) ; 
end if; -- if case_statement 

elsif ( L00P_STATEMENT j then 
return (TRUE); 

elsif (BLQCK_STATEMENT) then 

COOE_BLOCKER . I NCREMENT_STATEMENT_COUNT ; 
return (TRUE); 

e 1 si f ( TM .MATCH( TM . TQKEN_ACCEPT ) ) then 
if (ACCEPT_STATEMENT) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Compound statement" ) ; 
end if; -- if acceptstatement 

elsif ( SELECT_STATEMENT) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end COMPOUNDSTATEMENT; 
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BLOCKSTATEMENT — > [declare DECLARATIVE_PART ?] 



begin SEQUENCE_OF_STATEMENTS [exception 
[EXCEPTION_HANDLER]+ ?] ?] end [identifier ?] ; 



function BLOCK_STATEMENT return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT ( "BLQCK_STATEMENT" ) ; 
end if; 

if ( TM . MATCH ( TM . TORE N_DECL ARE ) ) then 
if ( DECLARATIVE_PART ) then 
null; 
else 

P4 . SYNTAX_ERROR( "Block statement" ) ; 

end if; -- if decl arative_part statement 

end if; — if match(token_declare) 

if ( TM . MATCH ( TM . TQKEN_BEGIN ) ) then 
if ( SEQUENCE_OF_STATEMENTS) then 

if ( TM .MATCH ( TM . TOKEN_EXCEPTION ) ) then 
if ( EXCEPT ION_HANDLER ) then 
while ( EXC EPT I ON_H ANGLER) loop 
null ; 
end loop; 
else 

P4 . SYNTAX_ERROR( "Block statement" ) ; 
end if; -- if exception_handler statement 

end if; -- if match( tokenexception ) 

if ( TM .MATCH ( TM . TOKEN_END) ) then 

if (TM.MATCH(TM.TOKEN_IDENTIFIER) ) then 



null ; 
end if; 

if ( TM .MATCH ( TM . TORE N_SEM I COLON ) ) then 



if match( token_identif ier) 



return (TRUE); 
else 



P4 . SYNTAX_ERROR( "Block statement" ) ; 
end if; 



if match( token_semicolon ) 



else 

P4.SYNTAX_ERROR( "Block statement") ; 



end if; 
e 1 se 



if match( tokenend) 



P4.SYNTAX_ERROR( "Block statement" ) ; 
end if; 



if sequence_of_statements 



else 



return ( FALSE ) ; 
end if; 

end BLOCK STATEMENT; 



if match( tokenbeg i n ) 
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- IF_STATEMENT --> EXPRESSION then SEQUENCE_OF_STATEMENTS 

[el si f EXPRESSION then SEQUENCE_OF_STATEMENTS]* 
[else SEQUENCE_OF_STArEMENTS ?] end if ; 
function IF_STATEMENT return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 
P4 . 0UT_PUT ( " I F_STATEMENT" ) ; 
end if; 



if (P3. EXPRESSION) then 

if ( TM. MATCH (TM. TO KEN_THEN) ) then 
if ( SEQUENCE_OF_STATEMENTS) then 

while (TM. MATCH(TM. TOKEN ELSIF)) loop 
if (P3. EXPRESSION) then 

if ( TM . MATCH( TM . TOKEN_THEN ) ) then 
if not ( SEQUENCE_OF_STATEMENTS ) then 
P4 . SYNTAX_ERROR( " I f statement" ) ; 
end if; -- if not sequence_of_statements 

else 

P4 . SYNTAX_ERROR( "If statement" ) ; 
end if; -- if match( token_then ) 

else 

P4 . SYNTAX_ERROR( "If statement”); 
end if; -- if expression statement 

end loop; 

if ( TM . MATCH ( TM . TOKEN_ELSE ) ) then 
if (SEQUENCE_OF_STATEMENTS) then 
null ; 
else 



P4 . SYNTAX_ERROR( " I f statement" ) ; 
end if; -- if sequence_of_statements 

end if; -- if match( token_el se ) 

if ( TM . MATCH ( TM . TOKEN_END) ) then 
if ( TM . MATCH( TM . T0KEN_I F ) ) then 

if (TM.MATCH(TM.TOKEN_SEMICOLON) ) then 
return (TRUE); 



else 

P4 . SYNTAX_ERROR( "If statement"); 
end if; 
el se 

P4 . SYNTAX_ERROR( * I f statement" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "If statement") ; 
end if; 
el se 

P4 . SYNTAX_ERROR( " I f statement" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "If statement" ) ; 
end if; 
el se 



if match( token_semi col on ) 



if match( token_if ) 



if match(token_end) 



if sequence_of_statements 



if match( token then) 
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-- if expression statement 



return (FALSE); 
end if; 

end I F_STATEMENT ; 



-- CASE_STATEMENT — > EXPRESSION is [CASE_STATEMENT_ALTERNATIVE]+ end case ; 
function CASE_STATEMENT return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .0UT_PUT ( "CASE_STATEMENT" ) ; 
end if; 

if (P3. EXPRESSION) then 

if ( TM .MATCH ( TM . TOKEN_IS) ) then 

if (CASE_STATEMENT_ALTERNATIVE) then 
while (CASE_STATEMENT_ALTERNATIVE) loop 
null; 
end loop; 

if ( TM .MATCH ( TM . T0KEN_END ) ) then 
if ( TM MATCH ( TM . TOKEN_CASE ) ) then 

if ( TM , MATCH ( TM . T0KEN_SEMIC0L0N ) ) then 
return (TRUE); 
el se 



P4 . SYNTAX_ERROR( "Case statement" ) ; 
end if; -- if match( token_semi col on ) 

el se 



P4 . SYNTAX_ERROR( "Case statement" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "Case statement" ) ; 
end if; 
else 

P4 .SYNTAX_ERROR( "Case statement" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "Case statement" ) ; 
end if; 
else 

return (FALSE); 
end if; 

end CASE_STATEMENT; 



if match( token_case) 



if match( token_end) 



if case_statement_al ternati ve 



if match( tokenis) 



if expression statement 



-- CASE_STATEMENT_AL TER NATIVE --> when CHOICE [| CHOICE]* => 

SEQUENCE_OF_STATEMENTS 

function CASE_STATEMENT_ALTERNATIVE return boolean is 
begin 

if ( P4 . PRINT_CALLS ) then 

P4.0UT_PUT("CASE STATEMENTALTERNAT IVE" ) ; 
end if; 
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if (TM.MATCH(TM. TOKEN_WHEN ) ) then 
if (P3. CHOICE) then 

while (TM.MATCH(TM. TOKEN_BAR ) ) loop 
if not (P3. CHOICE) then 

P4 .SYNTAX_ERROR( "Case statement alternative"); 
end if; -- if not choice statement 

end loop; 

if ( TM .MATCH ( TM . TOKEN_ARROW) ) then 
if (SEQUENCE_OF_STATEMENTS) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Case statement alternative"); 
end if; -- if sequence_of_statements 

else 

P4 . SYNT AX_ERR0R( "Case statement alternative"); 
end if; -- if match( tokenarrow) 

else 

P4 .SYNTAX_ERROR( "Case statement alternative"); 
end if; -- if choice statement 

else 

return (FALSE); 

end if; -- if match( tokenwhen) 

end CASE_STATEMENT_ALTERNATIVE; 



-- LOOP_STATEMENT --> [ I TERATION_SCHEME ?] loop 

SEQUENCE_OF_STATEMENTS end loop [identifier ?] ; 
function LOOP_STATEMENT return boolean is 
ST0P_T0KEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION_ONE ; natural; 

L0CATI0N_TW0 : positive; 
use SYMBOL_TABLE ; 
begin 

if (P4. PRINT _C ALLS) then 

P4 .OUT_PUT ( "LOOP_STATEMENT" ) ; 
end if; 

if (P3. ITERATION_SCHEME) then 
null; 

end if; -- if i teration_scheme statement 

if ( TM. MATCH ( TM. TOKEN_LOOP) ) then 
TM.MATCHED_ TOKEN ( STOPTOKEN ) ; 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATIONONE := C0DE_BL0CKER .CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKE R . EX I T_C0DE_BL0CK( STOP_TOKEN . SOURCE ) ; 

CODE BLOCKER . ENT ER_CODE_BLOCK(STOP_TOKEN .SOURCE , "LOOP BLOCK"); 

LOCAT IONTWO := CODE_BLOCKER . CURRENTCODE BLOCK_NUMBER ; 

CODEBLOCKER . INCREMENT_STATEMENT_C0UNT ; 

NET_GENERATOR . CONN EC T_B LOCKS ( LOCAT ION_ONE , LOCATION_TWO) ; 

SYMBOL_TABLE . INSERT_SYM TAB( "LOOP" , LOOPTAG, LOCATION_TWO) ; 
SYMBOLTABLE . INSERT_SYM TAB( "END" , LABEL_NAME , 0); 
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else 

CODE_BLOCKER . DEL£T£_CODE_BLOCK_ENTER ; 

CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE, "LOOP BLOCK"); 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

LOCATION_TWO := CODE_BLOCKER .CURRENT_CODE_BLOCK_NUMBER ; 

SYMBOL_TABLE . INS£RT_SYM_TAB( "LOOP" , LOOP_TAG, LOCATION_TWO ) ; 
SYMBOL_TABLE . INSERT_SYM_TAB( "END" , LAB£L_NAM£ , 0); 
end if; 

if (SEQUENCE_OF_STATEMENTS) then 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT = 0) then 
LOCATION_ON£ := 0; 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

else 

TM.MATCHED_TOKEN(STOP_TOKEN); 

LOCATlON_ONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKER . EXI T_CODE_BLOCK ( STOP_TOK£N . SOURCE ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_END ) ) then 
if ( TM . MATCH ( TM . TOKEN_LOOP ) ) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE, "END LOOP"); 
CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCATION_TWO : = CODEBLOCKER .CURRENT_CODE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . FIND_LOCAL_K£Y( "END" ) = null) then 
raise SYMBOL_TABLE . REF£RENCE_ERROR; 
else 

SYMBOL_TABLE.UPDATE_SYM_TAB(LOCATION_TWO) ; 
end if; 

if (LOCATION_ONE = 0) then 

NET_GENERATOR . EXPLICI T_END( LOCATION_TWO ) ; 
else 

N£T_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_TWO ) ; 
end if; 

CODE_BLOCKER .EXI T_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 

CODEBLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , " " ) ; 
if ( TM . MATCH ( TM . TOKEN_IDENTI FI ER ) ) then 
null ; 

end if; -- if match( token_identif ier) 

if ( TM . MATCH ( TM . TOKEN SEMI COLON) ) then 
SYMBOL_TABLE . EXITSCOPE ; 

NET_GENERATOR . END_LOOP( LOCATION_TWO, SYMBOL_TABLE . RETRI EVE_SYM ) ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Loop statement: expecting semicolon"); 
end if; -- if match( token_semi col on ) 

else 

P4 . SYNTAX_ERROR( "Loop statement: end must be fully bracketed"); 
end if; -- if match ( tokenl oop ) 

e 1 se 

P4. SYNTAX ERROR("Loop statement: expecting 'end’"); 
end if; -- if match ( tokenend ) 
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else 

P4 . SYNTAX_ERROR( "Loop statement: expecting sequence of statements”); 
end if; -- if sequence_of_statements 

else 

return (FALSE); 

end if; -- if match( token_loop ) 

end L00P_STATEMENT; 



— EXCEPT ION_HANDLER — > when EXCEPTION_CHOICE [| EXCEPTION_CHOICE]* => 
SEQUENCE_OF_STATEMENTS 

function EXCEPT I ON_HANDLER return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .Ol)T_PUT( "EXCEPTION_HANDLER" ) ; 

end if; 

if ( TM .MATCH { TM . TOKEN_WHEN ) ) then 
if ( P2 . EXCEPTION_CHOICE ) then 

while (TM.MATCH(TM.TOKEN_BAR) ) loop 
if not (P2.EXCEPTI0N_CH0ICE) then 

P4.SYNTAX_ERR0R( "Exception handler”) ; 
end if; -- if not exception_choice 

end loop; 

if ( TM .MATCH ( TM . T0KEN_ARR0W) ) then 
if ( SEQUENCE_OF_STATEMENTS) then 
return (TRUE); 
else 



P4.SYNTAX_ERR0R(" Except ion handler") 
end if; 
else 

P4.SYNTAX_ERR0R( "Exception handler”) ; 
end if; 
else 

P4 . SYNTAX_E RR0R( "Exception handler” ) ; 
end if; 
el se 

return (FALSE); 
end if; 

end EXCEPTION_HANDLER; 



if sequence_of_statements 



if match( token_arrow) 



if exception_choice statement 



if match( token-when ) 



-- ACCEPTSTATEMENT --> identifier [(EXPRESSION) ?] [FORMAL_PART ?] 

[do SEQUENCEOFSTATEMENTS end [identifier ?] ?] ; 
function ACCEPT_STATEMENT return boolean is 
STOPTOKEN : TOKEN SCANNER . TOKENRECORDTYPE ; 

LOCATIONONE : natural; 

LOCATION_TWO : positive; 
use SYMBOL_TABLE; 
beg i n 
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0) then 



if ( P4 . PRINT_CALLS) then 

P4 . OUT_PUT ( "ACCEPT_STATEMENT" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_IDENTI FIER ) ) then 
TM . MATCH ED_TOKEN( STOP_TOKEN ) ; 
if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 

CODEBLOCKER . lNCREMENT_STATEMENT_COUNT ; 

LOCATION_ONE := CODE_BLOCKER .CURRENT_CODE_BLOCK_NUMBER ; 
else 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

C0DE_BL0CKER . ENTER_C0DE_BL0CK( ST0P_T0KEN . SOURCE , "ACCEPT STATEMENT" ) ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

LOCATION_ONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
end if; 

CODEBLOCKER . ENTER_COOE_BLOCK( STOP_TOKEN . SOURCE , "ENTRY BLOCK"); 
LOCATION_TWO := CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

NET_GENERATOR . TASK_ACCEPT( LOCATION_ONE , LOCATION_TWO) ; 

SYMBOL_TABLE. INSERT_SYM_TAB(STOP_TOKEN. LEXEME* 1. .STOP_TOKEN. 

LEXEME_SI ZE ) , SYMBOL_TABLE . ACCEPT_TAG , 
LOCATION_TWO); 

CODE_BLOCKER . EXIT_CODE_BLOCK( STOP_TOKEN . SOURCE ) ; 
if { TM . MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (P3. EXPRESSION) then 

if ( TM . MATCH ( TM . TOKEN_RIGHT_PAREN ) ) then 
null; 
else 

P4.SYNTAX_ERR0R( "Accept statement" ) ; 
end if; 
else 

P4 . SYNTAX_ERROR( "Accept statement" ) ; 
end if; 
end if; 

if (P2. FORMAL_PART) then 
null ; 
end if; 

if (TM.MATCH(TM. TOKEN_DO ) ) then 
TM MATCHED_TOKEN(STOP_TOKEN); 

CODEBLOCKER . EXI T_C0DE_BL0CK( ST0P_T0KEN . SOURCE ) ; 

CODE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , 

"BEGIN ACCEPT STATEMENTS"); 

CODEBLOCKER . INCREMENT_STATEMENT_COUNT ; 
if (SEQUENCEOFSTATEMENTS) then 

if (CODE_BLOCKER.CURRENT_$TATEMENT_COUNT = 0) then 
LOCATIONONE := 0; 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 
else 

TM . MATCHED_TOKEN( STOP_TOKEN ) ; 

LOCAT IONONE := CODE BLOC KE R . CURRENTCODEBLOCKNUMBER ; 

CODE BLOCKER . E X I T CODE BLOCK ( STOP TOKEN . SOURCE ) ; 
end if; 



-- if match( token_right_paren) 



if expression statement 
if match( token l ef t_paren ) 



if formalpart statement 
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if (TM.MATCH(TM.TOKEN_END) ) then 
TM.MATCHED_TOKEN(STOP_TOKEN); 

CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE, "END ENTRY BLOCK"); 
CODE_BLOCKER.lNCREMENT_STATEMENT_COUNT; 

LOCAT ION_TWO := CODE_BLOCKER . CURRENT_COOE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . F IND_L0CAL_KEY( "END" ) = null) then 
raise SYMBOL_TABLE . REFERENCE_ERROR; 
else 



SYMBOL_TABLE . UPDATE_SYM_TAB( LOCATION_TWO ) ; 
end if; 

if ( LOCATION_ONE = 0) then 

NET_GENERATOR. EXPLICIT_END_ACCEPT ( LOCAT ION_TWO) ; 
else 

NET_GENERATOR . END_ACCEPT ( LOCATION_ONE , LOCAT ION_TWO ) ; 
end if; 



CODE_BLOCKER . EXIT_CODE_BLOCK{ STOP_TOKEN . SOURCE ) ; 

CODE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , "" ) ; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
null; 

end if; — if match{ tokenidentif ier) 

else 



P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if match( token_end ) 

else 

P4.SYNTAX_ERROR( "Accept statement" ) ; 
end if; -- if sequence_of_statements 

end if; — if match( token_do) 

if ( TM .MATCH ( TM . TOKEN_SEMI COLON ) ) then 
SYMBOL_TABLE . EXIT_SCOPE ; 
return (TRUE); 
else 



P4 . SYNTAX_ERROR( "Accept statement" ) ; 
end if; -- if match( token_semicol on ) 

else 

return (FALSE); 

end if; — if match( token_i denti f ier) 

end ACCEPT_STATEMENT; 



-- SELECT_STATEMENT --> select SELECT_STATEMENT_TAIL [ SELECT_ENTRY_CALL ?] 
end select ; 

function SELECTSTATEMENT return boolean is 
STOP_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATIONONE : positive; 

LOCATIONTWO : positive; 
use SYMBOLTABLE; 
beg i n 

if ( P4 . PRINT_CALLS) then 

P4 .OUT_PUT ("SELECT_STATEMENT"); 
end if; 
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if (TM.MATCH(TM.TOKENSELECT)) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

if (CODE_BLOCKER.CURRENT_STATEMENT_CDUNT /= 0) then 

LOCATION_ONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

COOE_BLOCKER . EXIT_COOE_BLOCK(STOP_TOKEN .SOURCE ) ; 
CODE_BLOCKER.ENTER_COOE_BLOCK(STOP_TOKEN. SOURCE, "SELECT BLOCK") ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

LOCATION_TWO := CODE_B LOCKER . CURRENT_COOE_BLOC K_NUMBER ; 
NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_TWO ) ; 
else 

CODE_8LOCKER . OELETE_CODE_BLOCK_ENTER; 

CODE_BLOCKER.ENTER_COOE_BLOCK(STOP_TOKEN. SOURCE, "SELECT BLOCK"); 
COOE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCATIONTWO := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
end if; 

SYMBOL_TABLE. INSERT_SYM_TAB( "SELECT" , SELECT_TAG , LOCATION_TWO ) ; 
SYMBOL_TABLE . INSERT_SYM_TAB( "END" , LABEL_NAME , 0); 

NET_GENERATOR.DECISION_START(LOCATION_TWO, SYHBOL_TABLE . RETRI EVESYM ) ; 
if (SELECT_STATEMENT_TAIL) then 
if (SELECT_ENTRY_CALL) then 

if ( TM .MATCH ( TM . TOKEN_END ) ) then 
if ( TM .MATCH ( TM . TOKEN_SELECT ) ) then 
if ( TM. MATCH (TM.TOKEN_SE MI COLON) ) then 
TM . MATCHEO_TOKEN( STOP_TOKEN ) ; 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATION_ONE := COOE_BLOCKER ,CURRENT_COOE_BLOCK_N UMBER; 
COOEBLOCKER . EXIT_COOE_BLOCK( STOP_TOKEN . SOURCE ) ; 

NET_GENERATOR . END_DEC ISION( LOCATION_ONE ) ; 
else 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 
NET_GENERATOR.EXPLICIT_END_DECISION; 
end if; 

COOE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , "END SELECT"); 
COOE_BLOCKER. INCREMENT_STATEMENT_COUNT; 

LOCATION_ONE CODE_BLOCKER . CURRENT_COOE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . FIND_LOCAL_KEY( "END" ) = null) then 
raise SYMBOL_TABLE . REFERENCE_ERROR; 
else 

SYMBOLTABLE . UPDATE_SYM_TAB( LOCATION_ONE ) ; 
end if; 

CODE_BLDCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE); 

CODEBLOCKER. ENTE R_CODE_BLOCK( STOP_TOKEN . SOURCE , "" ) ; 
SYMBOL_TABLE .EXITSCOPE; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Select statement" ) ; 
end if; -- if match( token_semicolon ) 

else 

P4.SYNTAX_ERROR( "Select statement"); 
end if; -- if match( token_select) 

e 1 se 
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P 4. SYNTAX_ERROR( "Select statement" ) ; 
end if; -- if match( tokenend ) 

elsif (TM.MATCH(TM.TOKEN_END) ) then 
if ( TM . MATCH ( TM . TOKEN_SELECT ) ) then 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
TM.MATCHED_TOKEN(STOP_TOKEN); 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE_BLOCKER . EXI T_C0DE_BL0CK( STOP_TOKEN . SOURCE ) ; 

NET_GENERATOR . END_DECISI0N( LOCATION_ONE ) ; 
else 

C0DE_BL0CKER . DELETE_CODE_BLOCK_ENTER ; 
NET_GENERATOR.EXPLICIT_END_DECISION; 
end if; 

CODE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , "END SELECT" ) ; 
C0DE_BL0CKER . INCREMENT_STATEMENT_COUNT ; 

LOCAT ION_ONE := CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
if ( SYMBOL_TABLE . F I ND_LOCAL_KEY ( "END" ) = null) then 
raise SYMBOL_TABLE . REFERENCE_ERROR ; 
else 

SYMBOL_TABLE . UPDATE_SYM_TAB( LOCATION_ONE ) ; 
end if; 

CODE_BLOCKER . EXI T_C0DE_B LOCK ( STOP_TOKEN . SOURCE ) ; 

C0DE_BL0CKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE , "" ) ; 
SYMBOL_TABLE . EXI T_SC0PE ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Select statement" ) ; 
end if; -- if match(token_semicolon) 

else 

P4 . SYNTAX_ERROR( "Select statement" ) ; 
end if; -- if match( token_sel ect ) 

else 

P4 . SYNTAX_ERROR{ "Select statement" ) ; 
end if; -- if match( token_end ) 

else 

P4 . SYNTAX_ERROR( "Select statement" ) ; 
end if; -- if select_statement_tai 1 

else 

return (FALSE); 
end if; 

end SELECT_STATEMENT ; 



-- SELECT_STATEMENT_TAIL --> SELECT_ALTERNATIVE [or SELECT_ALTERNATIVE ]• 
--> NAME ; [SEQUENCE_OF_STATEMENTS ?] 
function SE LEC TESTATE ME NT_TA I L return boolean is 
STOP_TOKEN ; TOKEN SCANNER . TOKEN RECORD TYPE ; 

LOCATIONONE : positive; 

SEARCH POINTER : SYMBOL TABLE. SYM_TAB_ACCESS; 
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use SYMBOLTABLE; 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT ( "SELECT_STATEMENT_TAIL" ) ; 
end if; 

if (SELECTALTERNATIVE) then 
while ( TM . MATCH ( TM . TOKENOR) ) loop 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE); 

NET_GENERATOR . DECISION_OR( LOCATION_ONE ) ; 
else 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 
NET_GENERATOR.EXPLICIT_DECISION_OR; 
end if; 

if not (SELECT_ALTERNATIVE) then 

P4 . SYNTAX_ERROR( "Select statement tail"); 
end if; 
end loop; 
return (TRUE); 
else 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 

if ( P3 . NAME ) then — check for entry call statement 

TM.MATCHED_TOKEN(STOP_TOKEN); 

SEARCH_POINTER := SYMBOL_TABLE . RETRI EVE_SYM ; 
if ( (SEARCH_POINTER /= null) and then 

(SEARCH_POINTER.TAG_TYPE = SYMBOL_TABLE . ENTRY_TAG ) ) then 
LOCATIONONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

CODE_BLOCKER . EXIT_CODE_BLOCK(STOP_TOKEN . SOURCE ) ; 
NET_GENERATOR.ENTRY_CALL(LOCATION_ONE, SEARCHPOINTER ) ; 

CODE_BLOCKER . ENTER_CODE_BLOCK(STOP_TOKEN . SOURCE , " " ) ; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
else 

SYMBOLTABLE . RESTORE_CURRENT_ENTRY ; 
return (FALSE); 
end if; 

if ( TM. MATCH (TM.TOKENSEMI COLON) ) then 
if (SEQUENCE_OF_STATEMENTS) then 
null; 

end if; -- if sequence_of_statements 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Select statement tail"); 
end if; -- if match( token_semi col on ) 

else 

return (FALSE); 
end if; 

end if; -- if select alternative statement 

end SELECTSTATEMENTTAIL; 



98 



-- SELECT_ALTERNATIVE --> [when EXPRESSION => ?] accept ACCEPT_STATEMENT 
[SEQUENCE_OF_STATEMENTS ?] 

— > [when EXPRESSION => ?] delay DELAY_STATEMENT 
[SEQUENCE_OF_STATEMENTS ?] 

--> [when EXPRESSION => ?] terminate ; 
function SELECT_ALTERNATIVE return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.0UT_PUT( "SELECT_AITERNATIVE" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_WHEN ) ) then 
if (P3. EXPRESSION) then 

if ( TM . MATCH ( TM . TOKEN_ARROW) ) then 
null; 
else 

P4 . SYNTAX_ERROR( "Select alternative"); 
end if; -- if match( token_arrow) 

else 

P4.SYNTAX_ERR0R( "Select alternative") ; 
end if; — if expression statement 

end if; -- if match( tokenwhen ) 

if ( TM. MATCH ( TM. TOKEN_ACCEPT ) ) then 
if (ACCEPT_STATEMENT) then 

if (SEQUENCE_OF_STATEMENTS) then 
null ; 

end if; --if sequence_of_statements 

return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Select alternative"); 
end if; -- if accept_statement 

elsif ( TM . MATCH( TM . TOKEN_DELAY ) ) then 
if (P3.DELAY_STATEMENT) then 

if ( SEQUENCE_OF_STATEMENTS ) then 
null ; 

end if; -- if sequence_of_statements 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Select alternative"); 
end if; -- if delay_statement 

elsif ( TM. MATCH (TM.TOKEN_TERMI NATE) ) then 
if ( TM. MATCH ( TM. TOKENSEMI COLON ) ) then 
return (TRUE); 
el se 

P4. SYNTAX ERROR( "Select alternative") ; 
end if; -- if match( tokensemicolon) 

else 

return (FALSE); 
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-- if match( token_accept) 



end if; 

end SELECT_ALTERNATIVE; 



— SELECTENTRYCALL — > else SEQl)ENCE_OF_STATEMENTS 

--> or delay DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS ?] 
function SELECT_ENTRY_CALL return boolean is 
STOP_TOKEN : TOKENSCANNER . TOKEN_RECORD_TYPE ; 

LOCATION_ONE : positive; 
begin 

if ( P4 . PRI NT_CALLS ) then 

P4.0UT_PUT( "SELECT_ENTRY_CALL" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_ELSE ) ) then 
TM . MATCH ED_TOK EN ( STOP_TOKEN) ; 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATION_ONE := CODE_B LOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

C0DE_BL0CKER . EXIT_CODE_BLOCK( ST0P_T0KEN . SOURCE ) ; 

NET_GENERATOR . DECISION_OR( L0CATI0N_0NE ) ; 
el se 

CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

NET_GENERATOR . EXPLIC I T_DEC ISI0N_0R ; 
end if; 

if ( SEQUENCE_OF_STATEMENTS) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Select entry call"); 
end if; -- if sequence_of_statements 

elsif ( TM . MATCH ( TM . TOKEN_OR ) ) then 
if ( TM .MATCH ( TM . TOKEN_DELAY ) ) then 
if ( P 3 . DELAY_STATEMENT ) then 

if (SEQUENCE_OF_STATEMENTS) then 
null; 

end if; -- if sequence_of_statements 

return (TRUE); 
else 

P4.SYNTAX_ERROR( "Select entry call"); 
end if; -- if del ay_statement 

else 

P4.SYNTAX_ERROR( "Select entry call"); 
end if; -- if match( token_delay ) 

el se 

return (FALSE); 

end if; -- if match( tokenelse) 

end SELECTENTRYCALL; 

end PARSER l ; 
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-- DESCRIPTION: This package defines the functions 

that are the middle level productions for a top-down, 
recursive descent parser. 



package PARSER_2 is 

function GENERIC_ACTUAL_PART return boolean; 
function GENERIC_ASSOCIATION return boolean; 
function GENERIC_FORMAL_PARAMETER return boolean; 
function GENERIC_TYPE_DEFINITION return boolean; 
function PRIVATE_TYPE_DECLARATION return boolean; 
function TYPE_DECLARATION return boolean; 
function SUBTYPEDECLARATION return boolean; 
function DISCRIMINANT_PART return boolean; 
function DISCRlMINANT_SPECIFICATION return boolean; 
function TYPE_DEFINITI0N return boolean; 
function RECORD_TYPE_DEFINITION return boolean; 
function COMPONENTLIST return boolean; 
function COMPONENT_DECLARATION return boolean; 
function VARIANT_PART return boolean; 
function VARIANT return boolean; 
function WI TH_OR_USE_CLAUSE return boolean; 
function FORMAL_PART return boolean; 
function IDENTIFIER_DECLARATION return boolean; 
function IDENTIFIERDECLARATIONTAIL return boolean; 
function EXCEPTION_TAIL return boolean; 
function EXCEPTIONCHOICE return boolean; 
function CONSTANT_TERM return boolean; 
function IDENTIFIERTAIL return boolean; 
function PARAMETERSPECIFICATION return boolean; 
function IDENTI FIERLIST return boolean; 
function MODE return boolean; 
function DESIGNATOR return boolean; 
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function SIMPLE_$TATEMENT return boolean; 
function ASSIGNMENT_OR_PROCEDURE_CALL return boolean 
function LABEL return boolean; 
function ENTRY_OECLARATION return boolean; 
function REPRESENTATION_CLAUSE return boolean; 
function RECORD_REPRESENTATION_CLAUSE return boolean 
end PARSER_2 ; 
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TITLE: 
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FILE NAME: 
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-- AUTHOR(S) : LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



-- DESCRIPTION: This package implements the functions 

that are the middle level productions for a top-down, 
recursive descent parser. Each function is preceded 
by the grammar productions they are implementing. 



with PARS£R_3 , PARS£R_4, TOKEN_MATCH£R , TOKEN_SCANNER , 

CODE_BLOCKER, SYMBOL_TABLE , NET_GENERATOR ; 

package body PARSER_2 is 

package TM renames TOKEN_MATCHER ; 
package P3 renames PARSER_3; 
package P4 renames PARSER4; 

-- GENERIC_ACTUAL_PART — > (GENERIC_ASSOCIATION [, GENERIC_ASSOClATION]* ) 
function GENERIC_ACTUAL_PART return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT ( "GENERIC_ACTUAL_PART" ) ; 
end if; 

if ( TM.MATCH( TM. T0KEN_LE FT_PAR£N ) ) then 
if (GENERIC_ASSOCIATION) then 

while (TM.MATCH(TM.TOKENCOMMA)) loop 
if not (GENERIC_ASSOCI ATION ) then 

P4 . SYNTAX_£RROR( "Generic actual part"); 
end if; -- if not generic_association 

end loop; 

if (TM.MATCH(TM.TOKENRIGHTPAREN)) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic actual part"); 
end if; -- if match( token right paren ) 

e 1 se 
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P4 . SYNTAX_ERROR( "Generic actual part"); 
end if; -- if generic association statement 

else 

return( FALSE ) ; 

end if; -- if match( tokenlef tparen ) 

end GENERIC_ACTUAL_PART; 



-- GENERIC_ASSOCIATION --> [GENERIC_FORMAL_PARAMETER ?] EXPRESSION 
function GENERIC_ASS0CIATI0N return boolean is 
begin 

if (P4.PRINTCALLS) then 

P4 . OUT_PUT ( "GENE RIC_ASSOCIATION" ) ; 
end if; 

if (GENERIC_FORMAL_PARAMETER) then 
null; 

end if; -- if generic_formal_parameter 

if ( P3 . EXPRESSION ) then -- check generic_actual_parameter 

return (TRUE); 
else 

return (FALSE); 

end if; -- if expression 

end GENERIC_ASSOC IATION ; 



-- GENERIC_FORMAL_PARAMETER --> identifier => 

--> string_l iteral => 

function GENERIC_FORMAL_PARAMETER return boolean is 
PEEK_AHEAD_TOKEN ; TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

TEST_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

use TOKEN_SCANNER; 

begin 

if (P4.PRINTCALLS) then 

P4 . 0UT_PUT ( "GENE RIC_FORMAL_PARAME TER" ) ; 
end if; 

TEST_TOKEN. LEXEME := (others => ' '); 

TEST_TOKEN . LEXEME (1. .2) := " = >"; 

TEST_TOKEN.LEXEME_SIZE := 2; 

TEST_TOKEN.TOKEN_TYPE := TOKENSCANNER .DELIMITER ; 

TM.NEXT_TOKEN( PEEK_AHEAD_TOKEN ) ; 
if (PEEK_AHEAD_TOKEN = TEST_TOKEN) then 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
if ( TM . MATCH ( TM . TOKENARROW ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic formal parameter"); 
end if; — if match( tokenarrow ) 

elsif ( TM . MATCH ( TM . TOKEN STRI NG _L ITERAL ) ) then 
if f TM.MATCH( TM. TOKEN ARROW)) then 
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return (TRUE); 



else 



P4 . SYNTAX_ERROR( "Generic formal parameter"); 



end if; 



-- if match( token_arrow) 



else 



P4. SY NT AX _ERROR( "Generic formal parameter"); 



end if; 
else 



-- if match( tokenidentif ier) 



return (FALSE); 
end if; 



if lookahead_token = "=> 



end GENERIC_FORMAL_PARAMETER; 



-- GENERIC_TYPE_DEFINITION --> ( <> ) 



--> range <> 
— > digits <> 
--> delta <> 



--> array ARRAY_TYPE_DEFINI TION 
--> access SUBTYPE_INDICATI0N 



function GENERIC_TYPE_DEFINITION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "GENERIC_TYPE_DEFINI TION" ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (TM. MATCH (TM.TOKEN_BRACKETS) ) then 
if ( TM.MATCH(TM.TOKEN_RIGHT_PAREN) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic type definition"); 
end if; -- if match(token_right_paren) 

else 

P4 .SYNTAX_ERROR( "Generic type definition"); 
end if; -- if match( tokenbrackets) 

elsif (TM.MATCH(TM. TOKEN_RANGE ) ) or else ( TM .MATCH ( TM . TOKEN_DIGI TS) ) 
or else (TM.MATCH(TM.TOKEN_DELTA) ) then 
if ( TM. MATCH ( TM. TOKEN_BRACKETS) ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic type definition"); 
end if; -- if match( token_brackets ) 

elsif (TM.MATCH(TM. TOKEN_ARRAY ) ) then 
if ( P3 . ARRAY_TYPE_DEFI NI TION ) then 
return (TRUE); 
else 

P4 . SYNTAX E RROR( "Generic type definition"); 
end if; - if array_type_def ini tion 

elsif ( TM .MATCH ( TM . TOKEN ACC ESS) ) then 
if ( P3 . SUBTYPEI NDICATION ) then 
return (TRUE); 
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el se 



P4 . SYNTAX_ERROR( "Generic type definition"); 
end if; -- if subtype_indication 

else 

return (FALSE); 

end if; -- if match( token_lef t_paren) 

end GENERICTYPEOEFINI TION ; 



-- PRIVATE_TYPE_DECLARATION --> [limited ?] private 
function PRIVATE_TYPE_DECLARATION return boolean is 
begin 

if ( P4 . PRINT_CALLS) then 

P4 .OUT_PUT ( "PRIVATE_TYPE_OECLARATION" ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_LIMI TED) ) then 
null; 
end if; 

if ( TM . MATCH ( TM . TOKEN_PRI VATE ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end PRIVATE_TYPE_OECLARATION; 



-- SUBTYPE_DECLARATION --> identifier is SUBTYPE_INOICATION ; 
function SUBTYPE_DEC LARA TION return boolean is 
begin 

if ( P4 PRINT_CALLS) then 

P4 .OUT_PUT( "SUBTYPEDECLARATION" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_IDENTI F IER ) ) then 
if ( TM . MATCH ( TM . TOKEN_IS) ) then 
if ( P3 . SUBTYPEINDICATION ) then 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Subtype declaration"); 
end if; -- if match( token_semicolon) 

else 

P4.SYNTAX_ERROR( "Sub type declaration"); 
end if; -- if subtype_indicat ion 

else 

P4 . SYNTAX_ERROR( "Subtype declaration") ; 
end if; -- if match( token_i s ) 

el se 

return (FALSE); 
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-- if match( tokenidentif ier) 



end if; 

end SUBTYPE_DECLARATION; 



-- T YPE_DEC LARA T ION --> identifier [DISCRIMINANTPART ?] 

[is PRIVATE_TYPE_DECLARATI0N ?]; 

--> identifier [DISCRIMINANT_PART ?] 

[is TYPE_DEFINITION ?]; 
function TYPE_DECLARATlON return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT{ "TYPE_DECLARATION" ) ; 
end if; 

if (TM.MATCH(TM.TOKEN_IDENTIFIER) ) then 
if (DISCRIMINANT_PART) then 
null ; 

end if; -- if discriminantpart 

if ( TM .MATCH( TM . TOKENIS) ) then -- declaration is full_type if 'is' 

if (PRIVATE_TYPE_DECLARATION) then 
null; 

elsif ( TYPEDEFINITION ) then -- present else incompl ete_type 

null ; 
else 

P4 . SYNTAX_ERROR( "Type declaration") ; 
end if; -- if type_def inition 

end if; -- if match( token_is ) 

if (TM.MATCH(TM.TOKEN_SEMICOLON) ) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Type declaration" ) ; 
end if; -- if match( token_semicolon ) 

else 

return (FALSE); 

end if; -- if match( token_identi f ier ) 

end TYPE_DECLARATION; 



-- OISCRIMINANTPART --> (OISCRIMINANTSPECIFICATION 

[; OISCRIMINANTSPECIFICATION]* ) 
function DISCRIMINANT_PART return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "DISCRIMINANTPART" ) ; 
end if; 

if ( TM.MATCH(TM.TOKEN_LEFT_PAREN)) then 
if (OISCRIMINANTSPECIFICATION) then 

while (TM.MATCH(TM. TOKEN_SE MI COLON ) ) loop 
if not (DISCRIMINANT SPECIFICATION) then 
P4 . SYNTAX_ERROR( "Discriminant part"); 



107 



-- if not discriminant_specif ication 



end if; 
end loop; 

if {TM.MATCH(TM. TOKENRIGHTPAREN ) ) then 
return (TRUE); 
else 

P4 . SVNTAX_ERROR( "Discriminant part" ) ; 
end if; -- if match{ token_right_paren) 

else 

P4 . SYNTAX_ERROR( "Discriminant part" ) ; 
end if; -- if discriminant_specif ication 

else 

return (FALSE); 

end if; -- if match( token_lef t_paren ) 

end DISCRIMINANT_PART; 



-- DI SCRIMINANT_SPECI F ICATION --> IDENTI FIER_LIST ; NAME [:= EXPRESSION ?] 
function DISCRIMlNANT_SPECIFICATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 , OUT_PUT ( "DI SCRIMI NAN T_SPEC I F ICATION" ) ; 
end if; 

if ( IDENTIFIER_LIST) then 

if ( TM .MATCH ( TM . TOKEN_COLON ) ) then 

if ( P3 . NAME ) then -- check for typejnark 

if (TM.MATCH(TM TOKEN_ASSIGNMENT) ) then 
if (P3. EXPRESSION) then 
null; 
else 

P4 . SYNTAX_ERROR( "Discriminant specification") ; 
end if; -- if expression statement 

end if; -- if match( token_ass ignment ) 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Discriminant specification" ) ; 
end if; -- if name statement 

else 

P4 . SYNTAX_ERROR( "Discriminant speci f ication" ) ; 
end if; -- if match( token_colon ) 

else 

return (FALSE); 

end if; -- if identif ier_l ist statement 

end DI SCRIMI NANT_SPECI F I CAT ION ; 



-- TYPE_DE F INI TION --> 
--> 
--> 

--> 



ENUMERATION_TYPE_DEF INI TION 
INTEGER_TYPE_DEFINITI0N 

digits FLOATING_OR_FIXED POINT CONSTRAINT 
delta FLOAIINGORFIXEDPOINTCONSTRAINI 



108 



--> array ARRAY_TYPE_DEFINITION 
--> record RECORD_TYPE_DEFINI TION 
--> access SUBTYPE_INDICATION 
--> new SU8TYPE_I ND I CAT I ON 
function TYPE_DEFINITION return boolean is 
begin 

if ( P 4 . PR I NT_CALLS ) then 

P4 .0UT_PUT ( "TYPE_DEFINITION" ) ; 
end if; 

if ( P4 .ENUMERATION_TYPE_DEF INI TION) then 
return (TRUE); 

elsif (P3.INTEGER_TYPE_DEFINITION) then 
return (TRUE); 

elsif ( TM. MATCH ( TM. TOKEN_DIGITS) ) or else (TM. MATCH (TM.TOKEN_DELTA) ) then 
if (P3.FLOATING_OR_FIXED_POINT_CONSTRAINT) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Type definition"); 

end if; -- f loating_or_f ixed_point_constraint 

elsif ( TM . MATCH ( TM. TOKEN_ARRAY ) ) then 
if ( P3 .ARRAY_TYPE_DEF INI TION) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Type definition"); 
end if; -- if ar ray_type_def inition 

elsif ( TM .MATCH ( TM . TOKEN_RECORD_STRUCTURE ) ) then 
if ( RECORD_TYPE_DEF INI TION ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "Type definition" ) ; 
end if; -- if record_type_def inition 

elsif (TM.MATCH(TM. TOKENACCESS) ) or else (TM. MATCH ( TM. TOKEN_NEW) ) then 
if ( P 3 . SUBTYPE_INDI CATION ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Type definition"); 
end if; -- if subtype_indication 

else 

return (FALSE); 
end if; 

end TYPE_DEFINITION; 



-- RECORD_TYPE_DEFINITlON --> COMPONENT_LIST end record 
function RECORDTYPEDEFINITION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT PUT ( ” RECORD_TYPE_DE F I N I TION" ) ; 
end if; 

if (COMPONENT LIST) then 
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if ( TM .MATCH ( TM . TOKEN_END) ) then 

if ( TM .MATCH ( TM . TOKEN_RECORD_STRUCTURE ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Record type definition"); 
end if; -- if match( token_record~structure ) 

else 

P4 . SYNTAX_ERROR( "Record type definition"); 
end if; -- if match( token_end ) 

else 

return (FALSE); 

end if; -- if component_l i st statement 

end RECORDTYPEDEFINITION ; 



-- C0MP0NENT_LI ST --> [COMPONENTDECLARATION]* [VAARI ANTPART ?] 
--> null ; 

function COMPONENT_LIST return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 . 0UT_PUT ( "C0MP0NENT_LIST" ) ; 

end if; 

while (COMPONENT_DECLARATION) loop 
null; 

end loop; 

if (VARIANTPART) then 
null; 

elsif ( TM .MATCH ( TM , TOKEN_NULL ) ) then 
if ( TM . MATCH ( TM . TOKEN_SEMICOLON ) ) then 
null ; 
end if; 

end if; 

return (TRUE); 
end COMPONENT_LI ST ; 



-- COMPONENT_DECLARATION --> IDENTI FI ER_LI ST : SUBTYPE_INDICATION 

[:= EXPRESSION ?] ; 

function COMPONENT DECLARATION return boolean is 
beg i n 

if ( P4 . PRI NT_CALLS ) then 

P4.0UT_PUT( "COMPONENTDECLARATION" ) ; 
end if; 

if ( IDENTI FIERLIST) then 

if ( TM .MATCH ( TM . TOKEN_COLON) ) then 
if ( P3 . SUB TYPE_ INDICATION) then 

if (TM MATCH(TM.TOKENASSIGNMENT) ) then 
if (P3. EXPRESSION) then 

if ( TM.MATCH(TM.TOKENSEMICOLON)) then 



no 



return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Component declaration" ) ; 
end if; -- if match( tokensemicol on ) 

else 

P4 . SYNTAX_ERROR( "Component declaration"); 
end if; -- if expression statement 

end if; -- if match( token_assignment) 

if (TM.MATCH(TM.TOKEN_SEMICOLON) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Component declaration" ) ; 
end if; -- if match( token_semi col on ) 

else 

P4 .SYNTAX_ERROR( "Component declaration" ) ; 
end if; -- if subtype_indicat ion statement 

else 

P4 ,SYNTAX_ERROR( "Component declaration" ) ; 
end if; -- if match(token_colon) 

else 

return (FALSE); 

end if; -- if identi f ier_l ist statement 

end COMPONENT_DECLARATION; 



-- VARIANT_PART --> case identifier is [VARI ANT]+ end case ; 
function VARIANT_PART return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4 .0UT_PUT ( "VARIANT_PART" ) ; 
end if; 

if (TM. MATCH (TM.TOKEN_CASE) ) then 

if (TM.MATCH(TM.TOKEN_IDENTIFIER) ) then 
if ( TM . MATCH ( TM . TOKEN_IS) ) then 
if (VARIANT) then 
while (VARIANT) loop 
null; 
end loop; 

if (TM.MATCH(TM.TOKEN_END)) then 
if ( TM . MATCH ( TM . TOKEN_CASE ) ) then 

if ( TM .MATCH ( TM . TOKENSEMICOLON ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Variant part" ) ; 
end if; -- if match(tokensemicolon) 

else 

P4.SYNTAX_ERR0R( "Variant part"); 
end if; -- if match( token_case ) 

el se 

P4. SYNTAX ERROR ("Variant part”); 
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-- if match( token_end) 



end if; 
else 

P4.SYNTAX_ERR0R( "Variant part"); 
end if; 
else 

P4 . SYNTAX_ERROR( "Variant part" ) ; 
end if; 
else 

P4.SYNTAX_ERR0R( "Variant part"); 
end if; 
else 

return (FALSE); 
end if; 

end VARIANT_PART ; 



if variant statement 



if match( tokenis) 



if match( token_identif ier ) 



if match( token_case ) 



-- VARIANT --> when CHOICE [| CHOICE]* => COMPONENTLIST 
function VARIANT return boolean is 
begin 

if ( P4 . PRINT_CALLS) then 
P4 .0UT_PUT ( "VARIANT" ) ; 
end if; 

if ( TM. MATCH ( TM. TOKEN_WHEN) ) then 
if (P3. CHOICE) then 

while ( TM, MATCH ( TM. T0KEN_BAR) ) loop 
if not (P3. CHOICE) then 

P4 . SYNTAX_ERROR( "Variant" ) ; 

end if; -- if not choice statement 

end loop; 

if ( TM .MATCH ( TM. T0KEN_ARR0W) ) then 
if <C0MP0NENT_LIST) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Variant" ) ; 

end if; -- if component_l ist statement 

else 

P4.SYNTAX_ERR0R( "Variant"); 

end if; -- if match( tokenarrow) 

else 

P4.SYNTAX_ERR0R( "Variant" ) ; 

end if; -- if choice statement 

else 

return (FALSE); 

end if; -- if match( token_when ) 

end VARIANT; 



WITHORUSE CLAUSE --> identifier [, identifier]* ; 
function WITH_0R USECLAUSE return boolean is 
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begin 

if ( P4 . PRINT_CALLS ) then 

P4 .OUT_PUT ( "WITH_OR_USE_CLAUSE" ) ; 
end if; 

if <TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
while (TM.MATCH(TM. TOKEN_COMMA ) ) loop 

if not ( TM . MATCH ( TM . TOKEN_IDENTI FIER ) ) then 
P4 . SYNTAX_ERROR( "With or use clause"); 
end if; 
end loop; 

if ( TM .MATCH ( TM . TOK E N_SEMI COLON ) ) then 
return (TRUE); 
else 

P4.SYNTAX_ERROR( "With or use clause"); 
end if; -- if match( token_semi col on ) 

else 

return (FALSE); 

end if; -- if match( tokenidentif ier) 

end WITH_OR_USE_CLAUSE; 



-- FORMAL_PART --> ( PARAMETER_SP EC I FICATION [; PARAMETER_SPEC I FICATION]* ) 

function FORMAL_PART return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4.0UT_PUT( "FORMAL_PART" ) ; 
end if; 

if ( TM .MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (PARAMETER_SPECIFICATION) then 

while (TM.MATCH(TM.TOKEN_SEMICOLON)) loop 
if not ( PARAMETER_SPEC I FICATION ) then 
P4.SYNTAX_ERR0R( "Formal part"); 

end if; -- if not parameter_speci f ication 

end loop; 

if ( TM .MATCH ( TM . TOKEN_RIGHT_PAREN ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Formal part" ) ; 

end if; -- if match( token_right_paren) 

el se 

P4 .SYNTAX_ERROR( "Formal part" ) ; 

end if; -- if parameterspecif ication 

el se 

return (FALSE); 

end if; -- if match( tokenl ef t_paren ) 

end FORMAL_PART ; 
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-- IDENTIFIE R_DEC L ARAT I ON --> IDENTIFIER_LIST : I DENT I FIER_DECLARATION_TAIL 
function IDENTIFIER_DECLARATION return boolean is 
beg i n 

if (P4.PRINTCALLS) then 

P4 . OUT_PUT ( " IDENTI FIER_DECLARATION" ) ; 
end if; 

if ( IDENTI FIER_LIST) then 

if ( TM . MATCH( TM . TOKEN_COLON ) ) then 
if ( IDENTI FIER_DECLARATION_TAIL) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Identifier decl aration" ) ; 
end if; -- if identif ierl ist 

else 

P4 .SYNTAX_ERROR( "Identifier declaration" ) ; 
end if; -- if match( token_colon ) 

else 

return( FALSE ) ; 

end if; -- if identif ier_l ist 

end IDENTI FI ER_DECLARAT ION ; 



--> 


exception EXCEPTION_TAIL 


--> 


constant CONSTANT_TERM 


--> 


array 


ARRAY_TYPE_DEF INI TION 




o 


EXPRESSION ?] ; 


--> 


NAME 


IDENTIFIER TAIL 



function IDENTIFIER_DECLARATION_TAIL return boolean 
begin 



if (P4.PRINT_CALLS) then 

P4 . OUT_PUT { "IDENTI FIER_DECLARATION_TAIL" ) ; 
end if; 



if ( TM , MATCH ( TM . TOKEN_EXCEPTION ) ) then 
if ( EXCEPTION_TAIL ) then 
return (TRUE); 
else 



P4 . SYNTAX_ERROR( " Identi fier declaration tail"); 
end if; -- if exception tail statement 

elsif ( TM . MATCH ( TM . TOKEN_CONSTANT ) ) then 
if (CONSTANTTERM) then 
return (TRUE); 
else 



P4.SYNTAX_ERROR( "Identifier declaration tail"); 
end if; -- if constant_term statement 

elsif ( TM . MATCH ( TM . TOKEN_ARRAY ) ) then 
if ( P3 . ARRAYTYPEDEF INI TION ) then 

if (TM.MATCH(TM.TOKEN_ASSIGNMENT)) then 
if (P3. EXPRESSION) then 
null ; 
el se 
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P4 . SYNTAX_ERROR( " Identi f ier declaration tail"); 
end if; -- if expression statement 

end if; -- if match( token_assignment ) 

else 

P4 . SYNTAX_ERROR( " Identi fi er declaration tail"); 
end if; -- if array_type_def ini tion 

if ( TM. MATCH (TM. T0KEN_SEMIC0L0N ) ) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Identifier declaration tail"); 
end if; -- if match(token_semicolon) 

elsif ( P3 . NAME ) then 

if ( IDENTIFIER_TAIL) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Identi f ier declaration tail"); 
end if; -- if identif iertai 1 

else 

return (FALSE); 

end if; -- if match( token_exception ) 

end IDENTI FI ER_DECLARATION_TAI L ; 



— EXCEPTION_TAI L — > ; 

--> renames NAME ; 

function EXCEPTION_TAIL return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .0UT_PUT( "EXCEPT 1 0N_TAIL" ) ; 
end if; 

if ( TM . MATCH ( TM . T0KEN_SEMIC0L0N ) ) then 
return (TRUE); 

elsif ( TM . MATCH ( TM. TOKEN_RE NAMES) ) then 
if ( P3 . NAME ) then 

if (TM.MATCH(TM. TOKEN_SE MI COLON ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Exception tail"); 

match ( token semicolon ) 



name statement 



match ( tokensemicolon ) 

end EXCEPTIONAL; 



end if; -- if 

else 

P4.SYNTAX_ERR0R( "Exception tail"); 
end if; --if 

else 

return (FALSE); 

end if; -- if 
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-- E X C E P T I ON C HO ICE --> NAME 

--> others 

function EXCEPTION_CHOICE return boolean is 
beg i n 

if ( P4 . PRINT_CALLS) then 

P4 . OUT_PUT ( " EXCEPT ION CHOICE " ) ; 
end if; 

if ( P3 . NAME ) then 
return (TRUE); 

elsif { TM .MATCH ( TM . TOKEN_OTHERS) ) then 
return (TRUE); 
el se 

return (FALSE); 
end if; 

end EXCEPTION_CHOICE; 



-- CONSTANT_TERM --> array ARRAY_TYPE_DEFINITION [:= EXPRESSION ?] ; 
--> := EXPRESSION ; 

--> NAME IDENTI FIER_TAIL 
function CONSTANT_TERM return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.0UT_PUT("C0NSTANT_TERM") ; 
end if; 

if ( TM . MATCH ( TM , TOKEN_ARRAY ) ) then 
if (P3.ARRAY_TYPE_DEFINITION) then 

if ( TM. MATCH (TM.TOKEN_ASSIGNMENT) ) then 
if (P3. EXPRESSION) then 
null ; 
else 

P4 , SYNTAX_ERROR( ’’Constant term'’ ) ; 
end if; -- if expression statement 

end if; -- if match( tokenass ignment ) 

else 

P4 .SYNTAX_ERROR( "Constant term" ) ; 

end if; -- if array_type_def inition 

if ( TM . MATCH ( TM . TOKEN_SEMI COLON ) ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Constant term" ) ; 

end if; -- if match(token_semicolon) 

elsif ( TM . MATCH ( TM . TOKEN_ASS IGNMENT ) ) then 
if (P3. EXPRESSION) then 

if (TM.MATCH(TM. TOKENSE MI COLON ) ) then 
return (TRUE); 
else 

P 4 . SYNTAX_ERROR( "Constant term" ) ; 

end if; -- if match( token semicolon ) 

e I se 
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-- if expression statement 



P4 . SYNTAX_ERROR( "Constant term" ) ; 
end if; 

elsif { P3 . NAME ) then 

if ( IDENTIFIE R_T AIL) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Constant term") ; 
end if; -- if identif ier_tail statement 

else 

return (FALSE); 

end if; -- if match( token_array ) 

end CONSTANT_TERM; 



-- IDENTIFIER_TAIL --> [CONSTRAINT ?] [;= EXPRESSION ?] ; 
--> [renames NAME ?] ; 
function IDENTIFIERTAIL return boolean is 



begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT ( " IDENTI FIER_TAIL" ) ; 
end if; 

if (P3. CONSTRAINT) then 
null ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_RE NAMES) ) then 
if ( P3 . NAME ) then 
null ; 
else 

P4.SYNTAX_ERR0R(" Identifier tail"); 
end if; 
end if; 

if (TM .MATCH ( TM. TOKEN_ASSIGNMENT ) ) then 
if (P3. EXPRESSION) then 
null ; 
else 

P4.SYNTAX_ERR0R(" Identifier tail”); 
end if; 
end if; 

if ( TM . MATCH ( TM . T0KEN_SEMIC0L0N ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end IDENTIFIER_TAIL; 



-- if constraint statement 



-- if name statement 
-- if match( token_renames ) 



-- if expression statement 
-- if match( token_assignment ) 



-- if match( token_semi col on ) 



-- PARAMETER_SPECI FICATION --> IDENTIFIE R_L 1ST : MODE NAME [:= EXPRESSION ?] 
function PARAMETER_SPECI F ICATION return boolean is 
beg i n 
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if (P4.PRINTCALLS) then 

P4 .OUT_PUT( "PARAMETER_SPECI FICATION" ) ; 
end if; 

if ( I DENT I F I ER_L 1ST ) then 

if ( TM . MATCH ( TM . TOKEN_COLON ) ) then 
if (MODE) then 

if ( P3 . NAME ) then -- check for typemark 

if ( TM .MATCH ( TM . TOKEN_ASSIGNMENT ) ) then 
if (P3. EXPRESSION) then 
null; 
else 

P4 .SYNTAX_ERROR( "Parameter specification"); 
end if; -- if expression statement 

end if; -- if match( token_assignment) 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Parameter specification"); 
end if; -- if name statement 

else 

P4 . SYNTAX_ERROR( "Parameter specification" ) ; 
end if; -- if mode statement 

else 

P4 .SYNTAX_ERROR( "Parameter specification") ; 
end if; -- if match( token_col on ) 

else 

return (FALSE); 

end if; -- if identifier! ist statement 

end PARAMETER_SPEC I FICATION ; 



-- IDENTIFIER_LIST --> identifier [, identifier]* 
function IDENTI FIE R_L I ST return boolean is 
TEMPTOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION : natural; 
begin 

if (P4.PRINT_CALLS) then 

P4. 0UT_PUT(" IDENTI F I E R_L I ST"); 
end if; 

if ( TM .MATCH ( TM . TOKEN_IDENTI FIER ) ) then 

LOCATION := CODE_BLOCKE R . CURRENT_CODE_BLOCK_NUMBE R ; 

TM.MATCHED_TOKEN( TEMP_TOKEN ) ; 

SYMBOL_TABLE . INSE RT_SYM_TAB( TEMP_TOKEN . LEXEME ( 1 . . TEMPTOKEN . LEXEME_SI ZE ) , 

SYMBOL_TABLE . OBJECT_DECLARATION_TAG , LOCATION ) ; 
while ( TM . MATCH ( TM . T0KEN_C0MMA ) ) loop 
if (TM.MATCH(TM.TOKEN_ IDENTIFIER)) then 
TM.MAICHED_TOKEN(TEMP_TOKEN); 

SYMBOL_TABLE . INSERT_SYM_TAB( TEMP_TOKEN . LEXEME ( 1 . . TEMP_TOKEN . LEXEME_SI ZE ) , 
SYMBOLTABLE . OBJECT_DECLARATION_TAG , 
LOCATION); 

else 
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P4.SYNTAX_ERR0R( "Identifier list” ); 
end if; -- if not match( token_identifer) statement 

end loop; 
return (TRUE); 
else 

return (FALSE); 

end if; -- if match( token_identif ier ) statement 

end IDENTI F I ER_LI ST ; 



-- MODE --> [in ?] 

--> in out 
--> out 

function MODE return boolean is 
begin 

if ( P 4 . PRINT_CALLS ) then 
P4 . OUT_PUT ( "MODE " ) ; 

end if; 

if ( TM . MATCH( TM . TOKENIN ) ) then 
if ( TM .MATCH ( TM . T0KEN_0UT) ) then 
null; 
end if; 

elsif ( TM . MATCH ( TM . TOKEN_OUT ) ) then 
null ; 

end if; 

return (TRUE); 
end MODE; 



-- DESIGNATOR --> identifier 

--> stringl i teral 
function DESIGNATOR return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4 . OUT_PUT ( "DESIGNATOR" ) ; 
end if; 

if (TM.MATCH(TM.TOKEN_ IDENTIFIER)) then 
return (TRUE); 

elsif ( TM.MATCH( TM. TOKEN_STRING_LI TERAL) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end DESIGNATOR; 



-- SIMPLE_STATEMENT --> null ; 

- > ASSIGNMENT _0R_P ROC EDURE_C ALL 
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--> exit EXIT_STATEMENT 
--> return RETURN_STATEMENT 
--> goto GOTO_STATEMENT 
--> delay DELAY_STATEMENT 
--> abort ABORT_STATEMENT 
--> raise RAISE_STATEMENT 
function SIMPLE_STATEMENT return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 

P4 . OUT_PUT ( "SIMPLE_STATEMENT" ) ; 

end if; 

if ( TM .MATCH ( TM . TOKEN_NULL ) ) then 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 
return (TRUE); 
el se 

P4 .SYNTAX_ERROR( "Simple statement" ) ; 
end if; 

elsif (ASSIGNMENT_OR_PROCEDURE_CALL) then -- includes a check for a 
return (TRUE); -- code statement and an 

elsif ( TM , MATCH ( TM . TOKEN_EXI T) ) then -- entry call statement, 

if (P3.EXIT_STATEMENT) then 

CODE_BLOCKER. INCREMENT_STATEMENT_COUNT; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple statement" ) ; 
end if; 

elsif ( TM .MATCH ( TM . TOKENRETURN ) ) then 
if (P3.RETURN_STATEMENT) then 

CODE_BLOCKER. INCREMENT_STATEMENT_COUNT; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple statement" ) ; 
end if; 

elsif ( TM. MATCH ( TM. TOKEN_GOTO) ) then 
if (P3.G0T0_STATEMENT) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple statement") ; 
end if; 

elsif ( TM . MATCH( TM . TOKEN_DELAY ) ) then 
if ( P3 . DELAY_STATEMENT ) then 

CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Simple statement" ) ; 
end if; 

elsif (TM.MATCH(TM. TOKEN ABORT ) ) then 
if (P3.AB0RTSTATEMENT) then 
CODEBLOCKER. INCREMENTSTArEMENTCOUNT; 
return (TRUE); 
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else 

P4.SYNTAX_ERR0R( "Simple statement"); 
end if; 

el si f ( TM . MATCH ( TM . TOKEN_RAISE ) ) then 
if (P3.RAISE_STATEMENT) then 

COOE_BLOCKER . INC REMEN T_STATEMENT_COUNT ; 
return (TRUE); 
else 

P4.SYNTAX_ERR0R( "Simple statement") ; 
end if; 
else 

return (FALSE); 
end if; 

end SIMPLE_STATEMENT; 



-- ASSIGNMENT_OR_PROCEDURE_CALL --> NAME := EXPRESSION ; 

--> NAME ; 

function ASSIGNMENT_OR_PROCEOURE_CAll return boolean is 
S£ARCH_POINTER : SYMBOL_TABLE . SYMTABACCESS ; 

SEARCH_TOKEN ; TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION_ONE : positive; 

use SYMBOL_TABLE ; 

begin 

if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "ASSIGNMENT_OR_PROCEDURE_CALL" ) ; 
end if; 

SYMBOL_TABlE.SAVE_CURRENT_ENTRY; 
if ( P3 . NAME ) then 

if ( TM .MATCH ( TM . TOKEN_ASSIGNMENT) ) then 
if (P3. EXPRESSION) then 

TM . MATCHEO_TOKEN( SEARCH_TOKEN ) ; 

SEARCH_POINTER := SYMBOLTABLE . RETRIEVE_SYM ; 
if ( ( SEARCH_POINTER /= null) and then 

( SEARCH_POINTER . TAG_TYPE = SYMBOL_TABLE . FUNCTION_DECLARATION_TAG ) ) then 
LOCATION_ONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

COO£_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

COOE_B LOCKER . EXIT_COOE_BLOCK( SEARCH_TOKEN . SOURCE ) ; 
NET_GENERATOR.CALL(LOCATION_ONE, SEARCH_POINTER ) ; 

COOE_BLOCKER . ENTER_CODE_BLOCK( SEARCH_TOKEN . SOURCE , ” ” ) ; 
else 

CODEBLOCKER . INCREMENTSTATEMENTCOUNT ; 
end if; 

if (TM.MATCH(TM.TOKEN_SEMICOLON)) then 
SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 

return (TRUE); -- parsed an assignment statement 

el se 

P4 . SYNTAX_ERROR( "Assignment or procedure call"); 
end if; -- if match( token_semi col on ) 

e 1 se 
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P4.SYNTAX_ERR0R( "Assignment or procedure call"); 
end if; -- if expression statement 

elsif (TM.MATCH(TM.T0KEN_SEMIC0L0N)) then 
TM.MATCHED_TOKEN(SEARCH_TOKEN); 

SEARCH_POI NTER := SYMBOL_TABLE . RETRIEVE_SYM ; 
if ( (SEARCH_POINTER /= null) and then 

(SEARCH_POINTER.TAG_TYPE = SYMBOL_TABLE . PROCEOURE_DECLARATION_TAG) ) then 
LOCAT I 0N_0NE := C0DE_BL0CKER . CURRENT_CODE_BLOCK_NUMBER ; 

COOE_BLOCKER . I NCREMENT_STATEMENT_COUNT ; 

CODEBLOCKER . EXIT_CODE_BLOCK(SEARCH_TOKEN . SOURCE ) ; 

NET_GENERATOR .CALL ( LOCAT I 0N_0NE , SEARCH ^POINTER ) ; 

COOE_BLOCKER . ENTER_CODE_BLOCK( SEARCH_TOKEN . SOURCE , " " ) ; 
elsif ( (SEARCH_POINTER /= null) and then 
( SEARCH_POINTER . TAG_TYPE = SYMBOL_TABLE . ENTRY_TAG) ) then 
LOCAT I0N_0NE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

CODE_BLOCKER. EXlT_CODE_BLOCK(SEARCH_TOKEN. SOURCE); 

NET_GENERATOR. ENTRY_CALL( LOCATION_ONE , SEARCH_POINTER ) ; 

C0DE_BL0CKER . ENTER_CODE_BLOCK( SEARCH_TOKEN . SOURCE , ""); 
end if; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 

return (TRUE); -- parsed a procedure call statement 

else 

P4 .SYNTAX_ERROR( "Assignment or procedure call"); 
end if; -- if match( token_assignment ) 

el se 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
return (FALSE); 

end if; -- if name statement 

end ASSIGNMENT_OR_PROCEDURE_CALL ; 



-- LABEL --> << identifier >> 

function LABEL return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATIONJ1NE : positive; 

L0CATI0N_TW0 : positive; 
use SYMBOL_TABLE; 
beg i n 

if (P4.PRINTCALLS) then 
P4.0UT_PUT( "LABEL"); 
end if; 

if (TM.MATCH(TM.TOKEN_LEFT_BRACKET)) then 
if ( TM .MATCH ( TM.TOKENIDENTIFIER)) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 
if (TM. MATCH(TM. TOKEN RIGHTBRACKET ) ) then 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATION ONE := COOEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE BLOCKER . EX I T_CODE _BLOCK( START TOKEN . SOURCE ) ; 

CODE BLOC KER. ENTER CODE BLOCK (STARTTOKEN. SOURCE, "LABELLED BLOCK" ) ; 
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LOCATION_TWO := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_TWO ) ; 
el se 

CODEBLOCKER . DELETE_CODE_BLOCK_ENTER ; 

CODE_BLOCKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "LABELLED BLOCK" ) ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

LOCATION_TWO := CODE_BLOCKER .CURRENT_CODE_BLOCK_NUMBER ; 
end if; 

if ( SYMBOL_TABLE . FIND_KEY(START_TOKEN . LEXEME ( 1 . . 

START_TOKEN . LEXEME_SI ZE ) ) = null) then 
SYMBOL_TABLE . I NSERT_SYM_TAB( START_TOKEN . 

LEXEME ( 1 . . START_TOKEN . LEXEME_SIZE ) , 
SYMBOL_TABLE . LABEL_NAME , LOCATION_TWO ) ; 

else 

SYMBOL_TABLE . UPDATE_SYM_TAB( LOCATION_TWO ) ; 
end if; 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Label " ) ; 

end if; -- if match( token_right_bracket) 

el se 

P4 . SYNTAX_ERROR( "Label " ) ; 

end if; — if match( token_identif ier) 

else 

return (FALSE); 

end if; -- if match( token_l ef t_bracket ) 

end LABEL; 



-- ENTRY_DECLARATION --> entry identifier [ ( DISCRETE_RANGE ) ?] 
[FORMAL_PART ?] ; 

function ENTRY_DECLARATION return boolean is 
START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 
begin 

if ( P 4 . P R I N T_C ALLS) then 

P4.0UT_PUT("ENTRY_DECLARATI0N"); 
end if; 

if ( TM . MATCH ( TM . TOKEN_ENTRY ) ) then 

if ( TM . MATCH ( TM.TOKEN_IDENTIFIER)) then 
TM.MATCHED_TOKEN(START_TOKEN); 

SYMBOL_TABLE . INSERT_SYM_TAB(START_TOKEN . LEXEME( 1 . . 

START_TOKEN . LEXEMESIZE ) , SYMBOL_TABLE . ENTRYTAG , 0); 
SYMBOL_TABLE . INSERT_SYM_TAB( "END" , SYMBOLTABLE . LABELNAME , 0) ; 
if (TM .MATCH ( TM . TOKEN_LE FT_PAREN ) ) then 
if (P3.DISCRETE_RANGE) then 

if ( TM .MATCH ( TM . TOKENR IGHT_PAREN ) ) then 
null ; 
el se 

P4.SYNTAX_ERRQR( "Entry declaration" ) ; 
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— if match( token_right_paren ) 



end if; 
else 

P4 . SYNTAX_ERROR( "Entry declaration" ) ; 
end if; -- if di screte_range statement 

end if; -- if match( token_left_paren) 

if (FORMAL_PART) then 
null ; 

end if; -- if formal_part statement 

if ( TM. MATCH ( TM. TOK EN_SE MI COLON ) ) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 

SYMBOLTABLE . EXIT_SCOPE ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Entry declaration" ) ; 
end if; -- if match(token_semicolon ) 

else 

P4 . SYNTAX_ERROR( "Entry declaration") ; 
end if; -- if match( token_identi f ier) 

el se 

return (FALSE); 

end if; -- if match( tokenentry ) 

end ENTRY_DECLARATION ; 



-- REPRESENTATION_CLAUSE --> for NAME use record RECORD_REPR£SENTATION_CLAUSE 
— > for NAME use [at ?] SIMPLE_EXPRESSION ; 
function REPRESENTATION_CLAUSE return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 

P4 OUT_PUT("REPRESENTATION_CLAUSE") ; 

end if; 

if ( TM .MATCH ( TM. TOKEN_FOR) ) then 
if ( P3 . NAME ) then 

if ( TM. MATCH (TM. TOKEN_USE) ) then 

if ( TM . MATCH ( TM . TOKEN_RECORD_STRUCTURE ) ) then 
if (RECORD_REPRESENTATION_CLAUSE) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Representation clause" ) ; 
end if; -- if recordrepresentationcl ause 

elsif ( TM .MATCH ( TM . TOKEN_AT ) ) then 
if (P3.SIMPLE_EXPRESSI0N) then 

if ( TM . MATCH ( TM . TOKEN_SEMI COLON ) ) then 
return (TRUE); 
e 1 se 

P4 . SYNTAX_ERROR( "Representation clause" ) ; 
end if; -- if match( tokensemicol on ) 

else 

P4 . SYNTAX ERROR ( " Rep resen tat ion clause"); 
end if; - if simpleexpression statement 
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elsif (P3.SIMPLE_EXPRESSI0N) then 

if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
return (TRUE); 
else 

P4 .SYNTAX_ERROR( "Representation clause") ; 
end if; -- if match( token_semicolon) 

el se 

P4 . SYNTAX_ERROR( "Representation clause") ; 
end if; -- if match( tokenrecord ) 

else 

P4 .SYNTAX_ERROR( "Representation clause" ) ; 
end if; -- if match( token_use ) 

else 

P4 . SYNTAX_ERROR( "Representation clause" ) ; 
end if; -- if name statement 

el se 

return (FALSE); 

end if; -- if match( token_f or ) 

end REPRESENTATION_CLAUSE; 



-- RECORD_REPRESENTATION_CLAUSE --> [at mod SIMPLE_EXPRESSION ?] 

[NAME at SIMPLE_EXPRESSION range RANGES]* 
end record ; 

function RECORDREPRESENTATIONCLAUSE return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .0UT_PUT ( "RECORD_REPRESENTATION_CLAUSE" ) ; 
end if; 

if ( TM .MATCH ( TM . T0KEN_AT ) ) then 
if (TM.MATCH(TM.TOKENMOD)) then 
if (P3.SIMPLE_EXPRESSI0N) then 
null ; 



P4.SYNTAX_ERR0R( "Record representation clause"); 

end if; -- if s impl eexpress ion 

else 

P4 .SYNTAX_ERROR( "Record representation clause"); 
end if; -- if match( tokenmod ) 

end if; -- if match( tokenat) 

while ( P3 . NAME ) loop 

if ( TM . MATCH ( TM . T0KEN_AT ) ) then 
if (P3.SIMPLEEXPRESSI0N) then 

if (TM.MATCH(TM.TOKENRANGE) ) then 
if (P3. RANGES) then 
null ; 
else 

P4 . SYNTAX_ERROR( " Record representation clause"); 
end if; -- if ranges statement 

else 
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P4 .SYNTAX_ERROR( "Record representation clause"); 



end if; 



— if match( token_range) 



else 



P4 . SYNTAX_ERROR( "Record representation clause"); 



end if; 



-- if simpl eexpress ion 



else 



P4 .SYNTAX_ERROR( "Record representation clause"); 



end if; 



- if match( token_at) 



end loop; 

if ( TM .MATCH ( TM . TOKEN_END) ) then 

if ( TM .MATCH ( TM . TOKEN_RECORD_STRUCTURE ) ) then 
if ( TM .MATCH( TM . T0KEN_SEMIC0L0N ) ) then 
return (TRUE); 
el se 

P4 .SYNTAX_ERROR( "Record representation clause"); 
end if; -- if match( token_semicolon) 

else 

P4 .SYNTAX_ERROR( "Record representation clause"); 
end if; -- if match( token_record_structure) 



else 



return (FALSE); 
end if; 



if match( token_end) 



end RECORD_REPRESENTATION_CLAUSE ; 



end PARSER_2; 



126 



TITLE: 



ADA FLOW 



-- MODULE NAME: PACKAGE PARSER_3 

— FILE NAME: PARSER3 .ADS 



-- DATE CREATED: 20 FEB 88 

-- LAST MODIFIED: 28 APR 88 

-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



DESCRIPTION: This package defines the functions 

that make up the baseline productions for a top-down, 
recursive descent parser. 



package PARSER_3 is 

function SUBT YPE_INDICAT ION return boolean; 

function ARRAY_TYPE_DEFINITION return boolean; 

function CHOICE return boolean; 

function ITERATIONSCHEME return boolean; 

function LOOP_PARAMETER_SPECI FICATION return boolean; 

function EXPRESSION return boolean; 

function RELATION return boolean; 

function RELATI0N_TAIL return boolean; 

function SIMPLE_EXPRESSI0N return boolean; 

function SIMPLE_EXPRESSI0N_TAIL return boolean; 

function TERM return boolean; 

function FACTOR return boolean; 

function PRIMARY return boolean; 

function CONSTRAINT return boolean; 

function FLOATING_OR_FIXED_POINT_CONSTRAI NT return boolean; 

function INDEX_CONSTRAINT return boolean; 

function RANGES return boolean; 

function AGGREGATE return boolean; 

function COMPONENT_ASSOCIATION return boolean; 

function ALLOCATOR return boolean; 

function NAME return boolean; 

function NAMETAIL return boolean; 

function LEFT_PAREN_NAME_TAIL return boolean; 

function ATTRIBUTEDESIGNATOR return boolean; 

function INTEGERTYPEDEFINITION return boolean; 

function DISCRETE RANGE return boolean; 

function EX I T_STATEMENT return boolean; 
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function RETURNSTATEMENT return boolean 
function G0T0_STATEMENT return boolean; 
function DELAY_STATEMENT return boolean; 
function ABORTSTATEMENT return boolean; 
function RAISE_STATEMENT return boolean; 
end PARSER_3 ; 



TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE PARSER_3 

-- FILE NAME: PARSER3 . AD8 



-- DATE CREATED: 20 FEB 88 

-- LAST MODIFIED: 28 APR 88 

-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



DESCRIPTION: This package implements the functions 

that make up the baseline productions for a top-down, 
recursive descent parser. Each function is preceded 
by the grammar productions they are implementing. 



with PARSER_4 , TOKEN_MATCHER, TOKEN_SCANNER , C0DE_BL0CKER , 
SYMBOL_TABLE, NET_GENERATOR ; 

package body PARSER3 is 

package TM renames TOKEN_MATCHER; 
package P4 renames PARSER4; 

-- SU8TYPE_INDICATI0N --> NAME [CONSTRAINT ?] 
function SUBTYPE_lNDICATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT( "SUBTYPE_INDICATION" ) ; 
end if; 

if (NAME) then -- check for type_mark 

if (CONSTRAINT) then 
null ; 
end if; 

return (TRUE); 
else 

return (FALSE); 
end if; 

end SUBTYPE_INDICATION; 



-- ARRAY_TYPE_DE F I N I TION --> ( INDEXCONSTRAINT of SUBTYPE_I NDICAT ION 

-- this function parses both constrained and unconstrained arrays 
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function ARRAY_TYPE_DEFINITION return boolean is 
beg i n 

if ( P4 . PRINT_CALLS ) then 

P4 .OUT_PUT( "ARRAY_TYPE_DEF INI TION" ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (INDEXCONSTRAINT) then 

if (TM.MATCH(TM„ TOKEN_OF ) ) then 
if (SUBTYPE_INDICATION) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Array definition" ) ; 
end if; -- if subtype_indication 

else 

P4 . SYNTAX_ERROR( "Array definition" ) ; 
end if; — if match( token_of ) 

else 

P 4 . SYNTAX_ERROR( "Array definition" ) ; 

end if; -- if i ndex_constrai nt statement 

el se 

return (FALSE); 

end if; -- if match( tokenlef tparen) 

end ARRAY_TYPE_DEFINI TION ; 



-- CHOICE --> EXPRESSION [ . . SIMPLE_EXPRESSION ?] 

--> EXPRESSION [CONSTRAINT ?] 

--> others 

function CHOICE return boolean is 
beg i n 

if ( P4 . PRINT_CALLS) then 
P4.0UT_PUT( "CHOICE"); 
end if; 

if (EXPRESSION) then 

if (TM,MATCH(TM.TOKEN_RANGE_DOTS) ) then -- check for di screte_range 
if (SIMPLEEXPRESSION) then 
null ; 
else 

P4 .SYNTAX_ERROR( "Choice" ) ; 

end if; -- if simpleexpression statement 

elsif (CONSTRAINT) then 
null; 

end if; -- if match token_range_dots 

return (TRUE); 

elsif ( TM . MATCH ( TM. TGKEN_OTHERS ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 
end CHOICE; 
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-- I TERATION_SCHEME --> while EXPRESSION 

--> for LOOP_PARAMETER_SPECI FICATION 
function ITERATION_SCHEME return boolean is 
beg i n 

if ( P 4 . PRINT_CALLS) then 

P4 . OUT_PUT ( " I TERATION_SCHEME ’’ ) ; 
end if; 

if (TM.MATCH(TM. T0KEN_WHI LE ) ) then 
if (EXPRESSION) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R(" Iteration scheme"); 
end if; 

el si f (TM.MATCH(TM.TOKEN_FOR) ) then 
if ( LOOP_PARAMETER_SPECI FICATION ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Iteration scheme" ) ; 
end if; 
el se 

return (FALSE); 
end if; 

end ITERATION_SCHEME; 



-- LOOP_PARAMETER_SPECI FICATION --> identifier in [reverse ?] DI SCRETE_RANGE 
function LOOP_PARAMETER_SPECI FICATION return boolean is 
begin 

if ( P4 . PRI NT_CALLS) then 

P4 ,0UT_PUT ( "LOOP_PARAMETER_SPEC I FICATION" ) ; 
end if; 

if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
if ( TM .MATCH ( TM . T0KEN_IN ) ) then 

if ( TM .MATCH ( TM . TOKEN_RE VERSE ) ) then 
null; 

end if; -- if match( token_reverse ) 

if ( DI SCRETE_RANGE ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Loop parameter specification"); 
end if; -- if discreterange statement 

else 

P4 . SYNTAX_ERROR( "Loop parameter specification"); 
end if; -- if match( token_in) 

else 

return (FALSE); 
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if match(token_identif ier) 



end if; 

end LOOP_PARAMETER_SPECI F ICATION ; 



-- EXPRESSION --> RELATION [RELATION_TAIL ?] 
function EXPRESSION return boolean is 
begin 

if ( P4 . PRI NT_CALLS) then 
P4 .OUT_PUT ("EXPRESSION"); 

end if; 

if (RELATION) then 

if (RELATIONTAIL) then 
null; 

end if; -- if relation_tai 1 statement 

return (TRUE); 

else 

return (FALSE); 

end if; -- if relation statement 

end EXPRESSION; 



-- RELATION --> SIMPLE_EXPRESSION [SIMPLE_EXPRESSION_TAIL ?] 
function RELATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4.0UT_PUT( "RELATION”); 

end if; 

if (SIMPLE_EXPRESSlON) then 

if (SIMPLE_EXPRESSION_TAIL) then 
null ; 

end if; -- if simple_expression_tai1 statement 

return (TRUE); 

else 

return (FALSE); 

end if; -- if simpleexpression statement 

end RELATION; 



— RELATION_TAIL --> [and [then ?] RELATION]* 
--> [or [else ?] RELATION]* 
--> [xor RELATION]* 

function RELATIONTAIL return boolean is 
beg i n 

if (P4.PRINT_CALLS) then 

P4 ,OUT_PUT( "RELATION TAIL" ) ; 
end if; 

while (TM.MATCH(TM. TOKENAND ) ) loop 
if ( TM . MATCH ( IM. TOKEN ! HEN)) then 
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-- if match( token_then ) 



null ; 
end if; 

if not (RELATION) then 

P4 . SYNTAX_ERROR( "Relation tail"); 
end if; 
end loop; 

while ( TM .MATCH ( TM . TOKEN_OR ) ) loop 
if ( TM .MATCH ( TM . TOKEN_ELSE ) ) then 
null; 
end if; 

if not (RELATION) then 

P4 ,SYNTAX_ERROR( "Relation tail"); 
end if; 
end loop; 

while ( TM. MATCH ( TM. TOKEN_XOR) ) loop 
if not (RELATION) then 

P4 . SYNTAX_ERROR( "Relation tail " ) ; 
end if; 
end loop; 
return (TRUE); 
end RELATI0N_TAIL; 



-- if not relation statement 



if match( token_el se) 



-- if not relation statement 



-- if not relation statement 



-- SIMPLE _EXPRE SSI ON --> [+ ?] TERM [BINARY_ADDING_OPERATOR TERM]* 
--> [- ?] TERM [BINARY ADDING_OPERATOR TERM]* 
function SIMPLE_EXPRESSION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT( "SIMPLE_EXPRESSION" ) ; 
end if; 

if ( TM .MATCH ( TM. TOKENPLUS) or TM . MATCH( TM . TOKEN_MINUS ) ) then 
if (TERM) then 

while (P4.BINARY_ADDING_0PERAT0R) loop 
if not (TERM) then 

P4 .SYNTAX_ERROR( "Simple expression" ) ; 
end if; -- if not term statement 

end loop; 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Simple expression" ) ; 
end if; -- if term statement 

elsif (TERM) then 

while (P4.BINARY_ADDING_0PERAT0R) loop 
if not (TERM) then 

P4 . SYNTAX_ERROR( "Simple expression"); 
end if; -- if not term statement 

end loop; 
return (TRUE); 
else 

return (FALSE); 
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-- if match( token_p1 us ) et al statement 



end if; 

end SIMPLE_EXPRESSI0N; 



-- SIMPLE_EXPRESSION_TAIL --> RELATIONAL_OPERATOR SlMPLE_EXPRESSION 
--> [not ?] in RANGES 
--> [not ?] in NAME 

function SIMPLE_EXPRESSI0N_TAIL return boolean is 
begin 

if ( P4 . PRI NT_CALLS) then 

P4 .0UT_PUT ( "SIMPLE_EXPRESSION_TAI L " ) ; 
end if; 

if <P4.RELATI0NAL_0PERAT0R) then 
if ( SIMPLE_EXPRESSION ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR{ "Simpl e expression tail"); 
end if; -- if simple_expression statement 

els if ( TM . MATCH ( TM TOKEN_NOT ) ) then 
if (TM.MATCH(TM TOKEN_IN)) then 
if (RANGES) then 
return (TRUE); 

elsif (NAME) then -- check for typejnark 

return (TRUE); 
else 

P4 ,SYNTAX_ERR0R( "Simple expression tail"); 
end if; -- if ranges statement 

else 

P4 ,SYNTAX_ERROR( "Simple expression tail"); 
end if; -- if match( token_in ) statement 

elsif ( TM . MATCH ( TM . TOKEN_IN ) ) then 
if (RANGES) then 
return (TRUE); 

elsif (NAME) then -- check for typejnark 

return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simpl e expression tail"); 
end if; -- if ranges statement 

else 

return (FALSE); 

end if; -- if relational_operator statement 

end SIMPLE_EXPRESSION_TAIL; 



-- TERM --> FACTOR [MULTI PLYING_OPERATOR FACTOR]* 
function TERM return boolean is 
begin 

if (P4. PRINT_CALLS) then 
P4.0UT_PUT("TERM"); 
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end if; 

if (FACTOR) then 

while (P4.MULTIPLYING_0PERAT0R) loop 
if not (FACTOR) then 

P4 ,SYNTAX_ERROR( "Term" ) ; 
end if; 
end loop; 
return (TRUE); 
else 

return (FALSE); 
end if; 
end TERM; 



-- FACTOR --> PRIMARY [** PRIMARY ?] 

--> abs PRIMARY 
— > not PRIMARY 

function FACTOR return boolean is 
begin 

if ( P4 . PRI NT_CALLS) then 
P4 .OUT_PUT ( "FACTOR" ) ; 
end if; 

if (PRIMARY) then 

if (TM.MATCH(TM.TOKEN_EXPONENT) ) then 
if (PRIMARY) then 
null ; 
else 

P4.SYNTAX_ERR0R(" Factor"); 
end if; 
end if; 

return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_ABSOLUTE ) ) then 
if (PRIMARY) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R(" Factor"); 
end if; 

elsif (TM.MATCH(TM.TOKEN_NOT) ) then 
if (PRIMARY) then 
return (TRUE); 
else 

P4.SYNTAX_ERR0R(" Factor"); 
end if; 
else 

return (FALSE); 
end if; 
end FACTOR; 



if not factor statement 



if factor statement 



if primary statement 
if match( tokenexponent ) 



if primary(abs) 



if primary(not) 
if primary statement 
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-- PRIMARY --> 
--> 

--> 

--> 

--> 



numeric_l i teral 
null 

stri ng_l i teral 
new ALLOCATOR 
NAME 

AGGREGATE 



function PRIMARY return boolean is 



beg i n 

if { P4 . PRINT_CALLS ) then 
P4.0UT_PUT( "PRIMARY"); 
end if; 

if (TM.MATCH( TM . T0KEN_NUMERIC_LITERAL ) ) then 
return (TRUE); 

elsif ( TM . MATCH ( TM . TOKEN_NULL ) ) then 
return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_STRING_Ll TERAL ) ) then 
return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_NEW) ) then 
if (ALLOCATOR) then 
return (TRUE); 
else 

P4 „ SYNTAX_ERROR( "Primary" ) ; 

end if; -- if allocator statement 

elsif (NAME) then 
return (TRUE); 
elsif (AGGREGATE) then 
return (TRUE); 
el se 

return (FALSE); 

end if; -- if match( token_l ef tparen ) 

end PRIMARY; 



-- CONSTRAINT --> 
--> 
--> 
--> 

function CONSTRAINT 



range RANGES 
range <> 

digits FLOATING_OR_FIXED_POINT_CONSTRAINT 
delta FLOATING_OR_FIXED_POINT_CONSTRAINT 
(INDEX_CONSTRAINT 
return boolean is 



beg i n 

if (P4.PRINT_CALLS) then 
P4 . OUT_PUT( "CONSTRAINT" ) ; 
end if; 

if (TM.MATCH(TM. TOKEN RANGE)) then 
if (RANGES) then 
return (TRUE); 

elsif ( TM . MATCH( TM . TOKEN_BRACKETS) ) then -- check for <> when parsing 
return (TRUE); -- an unconstrained array 

el se 



P4. SYNTAX_ERROR( "Const ra in t" ) ; 
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end if; — if ranges statement 

elsif ( TM . MATCH ( TM . TOKEN_DIGITS) } or else ( TM . MATCH ( TM . TOKEN_DELTA ) ) then 
if ( FLOATING J)R_FIXED_POINT_CONSTRAINT) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Constraint" ) ; 
end if; 

elsif ( TM . MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (INDEX_CONSTRAINT) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Constraint" ) ; 
end if; 
else 

return (FALSE); 
end if; 

end CONSTRAINT; 



-- FLOATING_OR_FIXED_POINT_CONSTRAINT --> SIMPLE_EXPRESSION [range RANGES ?] 
function FLOATING_OR_FIXED_POINT_CONSTRAINT return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 

P4 ,OUT_PUT ( "FLOATING_OR_FIXED_POINT_CONSTRAINT" ) ; 
end if; 

if ( SIMPLE_EX PRESS ION) then 

if ( TM. MATCH (TM.TOKEN_RANGE) ) then 
if (RANGES) then 
null ; 
else 

P4.SYNTAX_ERR0R( "Floating or fixed point constraint"); 
end if; -- if ranges statement 

end if; -- if match( tokenrange) 

return (TRUE); 
else 

return (FALSE); 

end if; -- if simpl eexpression statement 

end FL0ATING_0R_FIXED_P0INT_C0NSTRAINT; 



-- INDEX_CONSTRAINT --> DI SCRETE_RANGE [, DISCRETE_RANGE]* ) 
function I NDEX_CONSTRAINT return boolean is 
beg i n 

if (P4.PRINT_CALLS) then 

P4.0UT_PUT("INDEX_C0NSTRAINT" ); 
end if; 

if (DISCRETE_RANGE ) then 
while ( TM . MATCH ( TM . TOKENCOMMA ) ) loop 
if not (DISCRETERANGE) then 
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P4 . SYNTAX_ERROR( "Index constraint") ; 
end if; -- if not di screte_range 

end loop; 

if ( TM .MATCH ( TM . TOKEN_RI GHT_PAREN ) ) then 
return (TRUE); 
el se 

P4 . SYNTAX_ERROR( "Index constraint" ) ; 
end if; -- if match( token_r ight_paren ) 

else 

return (FALSE); 

end if; -- if di screte_range statement 

end INDEX_CONSTRAINT ; 



-- RANGES --> SIMPLE_EXPRESSION [ . . SIMPLE_EXPRESSION ?] 
function RANGES return boolean is 
begin 

if (P4.PRINT_CALLS) then 
P4 „OUT_PUT( "RANGES" ) ; 
end if; 

if (SIMPLE_EXPRESSION) then 

if (TM.MATCH(TM.TOKEN_RANGE_DOTS) ) then 
if (SIMPLE_EXPRESSION) then 
null; 
else 

P4.SYNTAX_ERR0R( "Ranges"); 

end if; -- if simpl e_express ion statement 

end if; -- if match( token_range_dots ) 

return (TRUE); 
else 

return (FALSE); 

end if; -- if simple_expression statement 

end RANGES; 



-- AGGREGATE --> ( COMPONENT_ASSOC I ATION [, COMPONENT_ASSOClATION]* ) 

function AGGREGATE return boolean is 
begin 

if ( P4 . PRI NT_CALLS ) then 
P4 . OUT_PUT ( "AGGREGATE” ) ; 
end if; 

if ( TM.MATCH( TM . TOKEN_LEF T_PAREN ) ) then 
if (C0MP0NENT_ASS0CIATI0N) then 

while ( TM .MATCH ( TM . T0KEN_C0MMA ) ) loop 
if not ( COMPONENT_ASSOC I ATION ) then 
P4 . SYNTAX_ERROR( "Aggregate" ) ; 

end if; -- if not component association 

end loop; 

if (TM. MATCH(TM. TOKEN RIGHTPAREN)) then 
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return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Aggregate" ) ; 

end if; -- if match( token_right_paren ) 

else 

P4.SYNTAX_ERR0R( "Aggregate" ) ; 

end if; -- if component_association 

else 

return (FALSE); 

end if; -- if match( tokenlef t_paren ) 

end AGGREGATE; 



-- COMPONENTASSOCIATION --> [CHOICE [| CHOICE]* => ?] EXPRESSION 
function COMPONENTASSOCIATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .OUT_PUT( "COMPONENTASSOCIATION" ) ; 
end if; 

if (CHOICE) then 

while ( TM .MATCH ( TM . TOKEN_BAR) ) loop 
if not (CHOICE) then 

P4 . SYNTAX_ERROR( "Component asociation" ) ; 
end if; 
end loop; 

if ( TM . MATCH( TM . TOKEN_ARROW) ) then 
if (EXPRESSION) then 
null ; 
else 

P4 . SYNTAX_ERROR( "Component asociation" ) ; 
end if; -- if expression statement 

end if; -- if match( token_arrow ) 

return (TRUE); 
else 

return (FALSE); 

end if; -- if choice statement 

end COMPONENT_ASSOCIATION; 



-- ALLOCATOR --> SUBTYPE_INDICATION [’AGGREGATE ?] 
function ALLOCATOR return boolean is 
beg i n 

if (P4.PRINT_CALLS) then 
P4 .OUTPUT ( "ALLOCATOR" ) ; 
end if; 

if ( SUB TYPE INDICATION ) then 

if (TM.MATCH(TM. TOKEN APOSTROPHE)) then 
if (AGGREGATE) then 
nul 1 ; 
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else 



P4.SYNTAX_ERR0R( "Allocator") ; 
end if; 
end if; 

return (TRUE); 
else 

return (FALSE); 
end if; 

end ALLOCATOR; 



-- if aggregate statement 
-- if match( token_apostrophe ) 



-- if subtype_indication statement 



-- NAME --> identifier [NAME_TAIL ?] 

--> character_l i teral [NAMETAIL ?] 

--> string Jiteral [NAME_TAIL ?] 
function NAME return boolean is 
SEARCH^POINTER : SYMBOL_TABLE . SYM_TAB_ACCESS; 

START_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATIONONE ; positive; 

LOCATIONTWO ; positive; 

use SYMBOLTABLE ; 

begin 

if (P4.PRINT_CALLS) then 
P4 .OUT_PUT( "NAME" ) ; 
end if; 

if ( TM. MATCH ( TM . T0KEN_I0ENTI FIER ) ) then 
TM MATCHED_TOKEN(START_TOKEN); 

SEARCHPOINTER := 

SYMBOL_TABLE.FIND_KEY(START_TOKEN. LEXEME ( 1. . STARTTOKEN . LEXEMESIZE ) ); 
if (NAME_TAIL) then 
null ; 

el si f ( TM.MATCH(TM.TOKEN_COLON) ) then 

if (CODE_BLOCKER.CURRENT_STATEMENT_COUNT /= 0) then 

LOCATIONONE := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKER . EXIT_CODE_BLOCK( START_TOKEN . SOURCE ) ; 

CODE_BLOCKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "LABELLED BLOCK") ; 
LOCATION_TWO := CODE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKER. INCREMENT_STATEMENT_COUNT; 
NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_TWO) ; 
else 

COOE_B LOCKER . DELETE_CODE_BLOCK_ENTER ; 

CODEBLOCKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "LABELLED BLOCK"); 
CODE_BLOCKER . INCREMENT_STATEMENT_COUNT ; 

LOCATION_TWO := CODEBLOCKER . CURRENTCODEBLOCKNUMBER ; 
end if; 

if (SYMBOL_TABLE.FIND_KEY(START TOKEN. LEXEME(1. . 

START_TOKEN . LEXEME_SI ZE ) ) = null) then 
SYMBOLTABLE . INSERT_SYM_TAB( STARTTOKEN . 

LEXEME( 1. . START_TOKEN . LEXEME_SIZE ) , 

SYMBOL TABLE. LABEL NAME, LOCATION TWO) ; 

el se 
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SYMBOL_TABLE . UPDATE_SYM_TAB( LOCATION_TWO ) ; 
end if; 

return (FALSE); 
end if; 

return (TRUE); 

elsif ( TM . MATCH ( TM . TOKEN_CHARACTER_LITERAL ) ) then 
if ( NAME_TAIL ) then 
null; 
end if; 

return (TRUE); 

elsif ( TM . MATCH ( TM. TOKEN_STRING_LITERAL ) ) then 
if ( NAME_TAIL ) then 
null ; 
end if; 

return (TRUE); 
else 

return (FALSE); 
end if; 
end NAME; 



-- NAME_TAIL — > 
--> 
--> 



( LEFT_PAREN_NAME_TAIL 
.SELECTOR [NAME_TAIL]* 

'AGGREGATE [NAME_TAIL]* 

' ATTRIBUTE_DESIGNATOR [NAME_TAIL]* 



function NAMETAIL return boolean is 



begin 

if ( P4 . PRI NT_CALLS ) then 
P4 ,OUT_PUT( "NAME_TAIL" ) ; 
end if; 



if (TM.MATCH(TM.TOKEN_LEFT_PAREN) ) then 
SYMBOL_TABLE . SAVE_CURRENT_EN TRY ; 
if (LEFT_PAREN_NAME_TAIL) then 

SYM80L_TABLE . RESTORE_CURRENT_ENTRY ; 
return (TRUE); 
else 

SYMBOL_TABLE.RESTORE_CURRENT_ENTRY; 
return (FALSE); 

end if; -- if lef t_paren_name_tail 

elsif (TM.MATCH(TM.TOKEN_PERIOD) ) then 
if (P4. SELECTOR) then 
while ( NAMETAIL ) loop 
null ; 



end loop; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Name tail : expecting selector”); 
end if; -- if selector statement 



elsif ( TM . MATCH ( TM . TOKEN APOSTROPHE ) ) then 
SYMBOLTABLE . SAVECURRENTENTRY ; 
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if (AGGREGATE) then 
while (NAME^TAIL) loop 
null ; 
end loop; 

SYMBOL_TABLE.RESTORE_CURRENT_ENTRY; 
return (TRUE); 

elsif (ATTRIBUTE_DESIGNATOR) then 
while (NAME_TAIL) loop 
null; 
end loop; 

SYMBOL_TABLE . RESTORE _CURRENT_ENTRY ; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Name tail : expecting aggregate or attribute"); 
end if; — if aggregate statement 

else 

return (FALSE); 

end if; -- if match( tokenlef t_paren ) 

end NAME_TAI L ; 



-- LEFT_PAREN_NAME_TAIL --> [ FORMAL_PARAMETER ?] EXPRESSION [..EXPRESSION ?] 

[, [FORMALPARAMETER ?] EXPRESSION [..EXPRESSION ?]]* 
) [NAME_TAIL]* 

function LEFTPARENNAMETAIL return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 ,OUT_PUT ( "LEFT_PAREN_NAME_TAIL" ) ; 
end if; 



if ( P4 . FORMAL_PARAMETER) then -- check for optional formal parameter 

null; -- before the actual parameter 

end if; -- if formalparameter statement 

if (EXPRESSION) then 

if ( TM . MATCH ( TM . TOKEN_RANGE_DOTS) ) then 
if not (EXPRESSION) then 

P4 . SYNTAX_ERROR( "Left paren name tail"); 
end if; -- if not expression statement 

end if; -- if match( token_range_dots ) 

while ( TM .MATCH ( TM . TOKENCOMMA) ) loop 
if ( P4 . FORMAL_PARAMETER) then 



null; 

end if; -- if f ormalparameter statement 

if not (EXPRESSION) then 

P4.SYNTAX_ERROR(" Left paren name tail”); 
end if; -- if not expression statement 

if ( TM . MATCH ( TM . TOKEN_RANGE_DOTS ) ) then 
if not (EXPRESSION) then 

P4 . SYNTAX_ERROR( "Left paren name tail"); 
end if; -- if not expression statement 

end if; -- if match( tokenrangedots ) 
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end loop; 

if ( TM . MATCH ( TM . TOKEN_RIGHT_PAREN ) ) then 
while ( NAME_TAI L) loop 
null ; 
end loop; 
return (TRUE); 
else 

return (FALSE); 

end if; -- if match( token_right_paren ) 

elsif (DISCRETE_RANGE ) then 

if ( TM. MATCH ( TM. TOKEN_RIGHT_PAREN ) ) then 
while (NAME_TAIL) loop 
null; 
end loop; 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Left paren name tail"); 
end if; 
else 

return (FALSE); 

end if; — if match( token_right_paren ) 

end LEFT_PAREN_NAME_TAIL; 



-- ATTRIBUTE_DESIGNATOR --> 
— > 
— > 



identifier [(EXPRESSION) 
range [(EXPRESSION) ?] 
digits [(EXPRESSION) ?] 
delta [(EXPRESSION) ?] 



--> 

function ATTRIBUTE_DESIGNATOR return boolean is 



?] 



begin 

if ( P4 . PRI NT_CALLS ) then 

P4 . OUT_PUT ( "ATTRIBUTE_DESIGNATOR" ) ; 
end if; 



if ( TM.MATCH( TM . TOKEN_IDENTI F I ER ) ) or else ( TM. MATCH ( TM. TOKEN_RANGE ) ) then 
if ( TM. MATCH ( TM . TOKEN_LEFT_PAREN ) ) then 
if (EXPRESSION) then 

if ( TM .MATCH ( TM . TOKEN_RIGHT_PAREN ) ) then 
null; 



else 



P4 . SYNTAX_ERROR( "Attribute designator" ) ; 
end if; -- if match( token_right_paren ) 

el se 



P4 . SYNTAX_ERROR( "Attribute designator"); 
end if; -- if expression statement 

end if; -- if match( token_lef t_paren) 

return (TRUE); 

elsif (TM.MATCH(TM.TOKEN_DIGITS)) or else ( TM . MATCH ( TM . TOKEN_DELTA ) ) then 
if ( TM . MATCH ( TM . TOKENLE FTP AREN ) ) then 
if (EXPRESSION) then 

if (TM. MATCH(TM. TOKEN RIGH TPAREN ) ) then 
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null ; 



else 

P4 . SYNTAX_ERROR( "Attribute designator" ) 



end if; -- if 

else 

P4 . SYNTAX_ERROR( "Attribute designator"); 
end if; -- if 

end if; -- if 

return (TRUE); 
else 

return (FALSE); 

end if; -- if 



match( token_right_paren ) 



expression statement 
match( token_lef t_paren ) 



match ( token_i denti f ier ) 



end ATTRIBUTE_DESIGNATOR ; 



— INTEGER_TYPE_DEFINITION — > range RANGES 
function INTEGERTYPEDEFINITION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 ,OUT_PUT( "INTEGER_TYPE_DEFINITlON" ) ; 
end if; 

if ( TM . MATCH( TM . TOKEN_RANGE ) ) then 
if (RANGES) then 
return (TRUE); 
el se 

P4.SYNTAX_ERR0R( "Integer type definition"); 
end if; 
else 

return (FALSE); 
end if; 

end INTEGER_TYPE_DEFINITION ; 



-- DISCRETE_RANGE --> RANGES [CONSTRAINT ?] 
function DISCRETE_RANGE return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "DISCRETE_RANGE" ) ; 

end if; 

if (RANGES) then 

if (CONSTRAINT) then 
null; 

end if; -- if constraint statement 

return (TRUE); 

else 

return (FALSE); 

end if; -- if ranges statement 

end DISCRETE RANGE; 
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-- EXIT_STATEMENT --> [NAME ?] [when EXPRESSION ?] ; 
function EXIT_STATEMENT return boolean is 
begin 

if (P4. PRINT CALLS) then 

P4 . 0UT_PUT ( "EXI T_STATEMENT" ) ; 
end if; 

if (NAME) then 
null ; 

end if; -- if name statement 

if ( TM . MATCH ( TM . TOKEN_WHEN ) ) then 
if (EXPRESSION) then 
null ; 
else 

P4 . SYNTAX_ERROR( "Exit statement"); 
end if; -- if expression statement 

end if; -- if match( token_when ) 

if ( TM .MATCH ( TM . TOKENSEMICOLON ) ) then 
return (TRUE); 
else 

return (FALSE); 

end if; -- if match( token_semicolon ) 

end EXIT_STATEMENT ; 



-- RETURNSTATEMENT --> [EXPRESSION ?] ; 
function RETURN_STATEMENT return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4 .0UT_PUT( "RETURN_STATEMENT" ) ; 
end if; 

if (EXPRESSION) then 
null; 
end if; 

if ( TM . MATCH ( TM . TOKEN_SEMICOLON ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end RETURN_STATEMENT; 



-- GOTO_STATEMENT --> NAME ; 
function G0T0_STATEMENT return boolean is 
STARTTOKEN : TOKENSCANNE R . TOKENRECORDTYPE ; 
LOCATIONONE : positive; 
use SYMB0LTA8LE ; 
begin 
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if (P4.PRINT_CALLS) then 

P4 . OUT_PUT ( "GOTO_STATEMENT" ) ; 
end if; 

if (NAME) then 

TM.MATCHED_TOKEN(START_TOKEN) ; 

i f ( SYMBOL_TABLE . FIND_KEY( START_TOKEN . LEXEME( 1 . . STARTJTOKEN . LEXEME_SI ZE ) ) 

= null) then 

SYMBOL_TABLE . INSERT_SYM_TAB( START _T0KEN . LEXEME( 1 . . START_TOKEN . 

LEXEME_SI ZE ) , SYMBOL_TABLE . LABEL_NAME , 0 ) ; 
end if; 

LOCATION_ONE := CODE_BLOCKER ,CURRENT_CODE_BLOC K_NUMBER ; 

NET_GENERATOR GO_TO( LOCATION_ONE , 

SYMBOL_TABLE . FIND_KEY( START_TOKEN . LEXEME ( 1 . . START_TOKEN . LEXEME_SI ZE ) ) ) ; 
CODE_BLOCKER . INCREM£NT_STAT£MENT_COUNT ; 

CODE_BLOCKER . EX I T_CODE_BLOCK( START_TOKEN . SOURCE ) ; 

COOE_BLOCKER . ENTER_CODE_BLOCK( START_TOKEN . SOURCE , "" ) ; 
if ( TM .MATCH ( TM . TOKEN_SEMICOLON ) ) then 
return (TRUE); 
else 

P4 SYNTAX_ERROR( "Goto statement"); 

end if; -- if match( token_semicol on ) 

else 

return (FALSE); 

end if; -- if name statement 

end GOTO_STATEMENT ; 



-- DELAY_STATEMENT --> SIMPLE_EXPRESSION ; 
function DELAY_STATEMENT return boolean is 
begin 

if ( P4 . PRINT_CALLS) then 

P4 . OUT_PUT ( "DELAYSTATEMENT" ) ; 
end if; 

if ( SIMPLE_EXPRESSION ) then 

if ( TM .MATCH ( TM . TOKEN_SE MI COLON ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Delay statement" ) ; 
end if; -- if match( token_semi col on ) 

else 

return (FALSE); 

end if; -- if simple_express ion statement 

end DELAY_STATEMENT ; 



-- ABORT_STATEMENT --> NAME [, NAME]* ; 
function ABORT_STATEMENT return boolean is 
beg i n 

if ( P4 . PR I N TCAL LS ) then 
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P4 .OUT_PUT ( ” ABORT_STATEMENT" ) ; 
end if; 

if (NAME) then 

while ( TM. MATCH ( TM . TOKEN_C0MMA) ) loop 
if not (NAME) then 

P4.SYNTAX_ERROR( "Abort statement"); 
end if; 
end loop; 

if ( TM. MATCH ( TM . TOKEN_SEMI COLON ) ) then 
return (TRUE); 
else 

P4 . SYNTAX_ERROR( "Abort statement" ) ; 
end if; 
else 

return (FALSE); 
end if; 

end ABORT_STATEMENT ; 



-- RAISE_STATEMENT --> [NAME ?] ; 
function RAISESTATEMENT return boolean is 
begin 

if ( P4 . PRINT_CALLS ) then 

P4.0UT_PUT( "RAISESTATEMENT" ) ; 
end if; 

if (NAME) then 
null ; 
end if; 

if ( TM. MATCH ( TM . TOKENSEMICOLON ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end RAISE_STATEMENT; 
end PARSER_3 ; 



if not name statement 



if match( token_semicolon) 



if name statement 
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TITLE: 



ADA FLOW 



-- MODULE NAME: PACKAGE PARSER4 

-- FILE NAME: PARSER4 . ADS 



-- DATE CREATED: 20 FEB 88 

-- LAST MODIFIED: 28 APR 88 

-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 



-- DESCRIPTION: This package defines the functions that 

are the lowest level productions for a top-down, 
recursive descent parser. 

• * «« 9 * S * •*«««««#£ 8 **««*•£*»*»?**» 4 •**»«««»*«••£«*««*•• * 

with TEXT_I0, TOKEN_MATCHER; 
package PARSER_4 is 

PRINT_CALLS : boolean := FALSE; 



PARSER_ERROR : exception; 

function MULTIPLYING_OPERATOR return boolean; 
function BINARY_ADDlNG_OPERATOR return boolean; 
function RELATIONAL_OPERATOR return boolean; 
function ENUMERATION_TYPE_DEF IN ITION return boolean; 
function ENUMERATION_LI TERAL return boolean; 
function FORMAL_PARAMETER return boolean; 
function SELECTOR return boolean; 



procedure SYNTAX_ERROR( ERROR_MESSAGE : in string); 
procedure OUTPUT ( FUNCTIONNAME : in string); 
end PARSER_4 ; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: 

-- FILE NAME: 

-- DATE CREATEO: 
-- LAST MODIFIED: 



PACKAGE PARSER_4 
PARSER4 . ADB 

20 FEB 88 
28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



— BASEO ON A MOOIFIEO AOA GRAMMAR OEVELOPEO BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCOR PAUL M. HERZIG, USN 



-- DESCRIPTION: This package implements functions that 

are the lowest level productions for a top-down, 
recursive descent parser. Each function is preceded 
by the grammar productions they are implementing. 



with TOKEN_MATCHER, TOKEN_SCANNER , TEXT_I0, SYMBOL_TABLE ; 



package body PARSER_4 is 

package TM renames TOKEN_MATCHER ; 



-- MULTIPLYING_OPERATOR --> * 

--> / 

--> mod 
--> rem 

function MULTIPLYING_OPERATOR return boolean is 
begin 

if (PRINT_CALLS) then 
0UT_PUT ( "MULTIPLYING_OPERATOR'’ ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_ASTERI SK ) ) then 
return (TRUE); 

elsif ( TM . MATCH ( TM . TOKEN_SLASH ) ) then 
return (TRUE); 

elsif (TM.MATCH(TM.TOKEN_MOD)) then 
return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_REM ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end MULTIPLYING OPERATOR; 
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-- BINARYADDINGOPERATOR — > + 

--> 

--> & 

function BINARY_ADDING_OPERATOR return boolean is 
begin 

if (PRINT_CALLS) then 
OUT_PUT( "BlNARY_ADDING_OPERATOR" ) ; 
end if; 

if ( TM. MATCH (TM.TOKEN_PLUS) ) then 
return (TRUE); 

elsif ( TM . MATCH ( TM. TOKEN_MINUS) ) then 
return (TRUE); 

elsif ( TM , MATCH( TM. TOKEN_AMPERSAND ) ) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end BINARY_ADDING_0PERAT0R; 



-- RELATIONAL_OPERATOR — > = 

--> / = 

--> < 

--> < = 

--> > 

--> > = 

function RELATIONALOPERATOR return boolean is 
beg i n 

if (PRINT_CALLS) then 

0UT_PUT ( "RELATI0NAL_0PERAT0R" ) ; 

end if; 

if (TM.MATCH(TM.TOKEN_EQUALS) ) then 
return (TRUE); 

elsif (TM.MATCH(TM. TOKEN_NOT_EQUALS) ) then 
return (TRUE); 

elsif (TM.MATCH(TM.TOKEN_LESS_THAN)) then 
return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_LESS_THAN_EQUALS ) ) then 
return (TRUE); 

elsif ( TM. MATCH ( TM. TOKEN_GREATER_THAN ) ) then 
return (TRUE); 

elsif (TM.MATCH( TM. TOKEN GREATERTHANEQUALS) ) then 
return (TRUE); 

else 

return (FALSE); 

end if; 

end RELATIONAL OPERATOR; 
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-- ENUMERAT ION_TY PE _DE F I N I T I ON --> ( ENUMERATIONLITERAL 

[, ENUMERATIONLITERAL]*) 

function ENUMERATION_TYPE_DEF IN ITION return boolean is 
begin 

if (PRINT_CALLS) then 
OUT_PUT ( "ENUMERAT ION_TYPE_DEF INI T ION" ) ; 
end if; 

if (TM.MATCH(TM.TOKEN_LEFT_PAREN)) then 
if ( ENUMERAT ION_LIT ERA L ) then 

while (TM.MATCH(TM.TOKEN_COMMA)) loop 
if not (ENUMERATIONLITERAL) then 

SYNTAX_ERROR( "Enumeration type definition"); 
end if; -- if not enumeration^ iteral 

end loop; 

if (TM.MATCH(TM.TOKEN_RIGHT_PAREN)) then 
return (TRUE); 
else 

SYNTAX_ERROR( "Enumeration type definition"); 
end if; -- if match( token_right_paren ) 

else 

SYNTAX_ERROR( "Enumeration type definition"); 
end if; -- if enumeration^ i teral statement 

else 

return (FALSE); 

end if; -- if match( token_l ef t_paren ) 

end ENUMERATION_TYPE_DEFINITION; 



-- ENUMERATION_LITERAL --> identifier 

--> character_l i teral 

function ENUMERATIONLITERAL return boolean is 
begin 

if (PRINT_CALLS) then 

0UT_PUT( "ENUMERATIONLITERAL" ) ; 
end if; 

if ( TM . MATCH ( TM . TOKEN_IDENTI F IER ) ) then 
return (TRUE); 

elsif (TM.MATCH(TM.TOKEN_CHARACTER_LITERAL)) then 
return (TRUE); 
else 

return (FALSE); 
end if; 

end ENUMERATIONLITERAL; 



- FORMAL PARAMETER --> identifier => 
function FORMAL PARAMETER return boolean is 
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PEEK_AHEAD_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 
TEST_TOKEN : TOKENSCANNER . TOKEN_RECORD_TYPE ; 
use TOKEN_SCANNER; 
begin 

if (PRINT_CALLS) then 
0UT_PUT ( " FORMA L_PARAME TER” ) ; 
end if; 

TEST_TOKEN. LEXEME := (others => ' '); 

TEST_TOKEN . LEXEME (1.. 2) := 

TESTTOKEN . LEXEMESIZE := 2; 

TESTTOKEN . TOKEN_TYPE ;= TOKENSCANNER . DELIMI TER ; 
TM . NEXT_TOKEN( PEEK_AHEAD_TOKEN ) ; 
if (PEEK_AHEAD_TOKEN = TEST_TOKEN ) then 
if { TM .MATCH ( TM . TOKEN_IDENTI FIER ) ) then 
if ( TM . MATCH ( TM . TOKEN_ARROW) ) then 
return (TRUE); 
else 

SYNTAX_ERROR( "Formal parameter" ) ; 
end if; 
else 

SYNTAX_ERROR( "Formal parameter" ) ; 
end if; 
else 

return (FALSE); 
end if; 

end FORMAL_PARAMETER; 



if match( token_arrow) 



-- if match(token_identif ier) 



-- SELECTOR --> identifier 

--> characterl i teral 
--> string_literal 
--> all 

function SELECTOR return boolean is 
SEARCHPOINTER : SYMBOL_TABLE . SYM_TAB_ACCESS ; 

SEARCH_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

use SYMBOLTABLE; 

begin 

if ( PRINT_CALLS ) then 
OUT_PUT( "SELECTOR" ) ; 
end if; 

if ( TM . MATCH ( TM . TOKENIDENTI F IER ) ) then 
TM.MATCHED_TOKEN(SEARCH_TOKEN); 

SEARCHPOINTER := SYMBOL_TABLE . RETRIEVE_SYM; 
if (SEARCH_POINTER /= null) then 

SEARCH_POINTER := SYMBOL_ TABLE . SELECT_COMPONE NT( SEARCH_TOKEN . 

LEXEME ( 1 . . SEARCH_TOKEN . LEXEME_SIZE ) ) ; 

end if; 

return (TRUE); 

elsif ( TM. MATCH ( TM . TOKEN CHARACTERL I TERAL ) ) then 
return (TRUE); 
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elsif ( TM . MATCH ( TM . TOKEN_STRING_LITERAL ) ) then 
return (TRUE); 

elsif ( TM .MATCH ( TM . TOKEN_ALL) ) then 
return (TRUE); 
el se 

return (FALSE); 
end if; 
end SELECTOR; 

procedure SYNTAX_ERROR( ERROR_MESSAGE : in string) is 
begin 

TEXT_IO . new_l i ne ( 2 ) ; 

TEXT_IO . put( "Incomplete "); 

TEXT_I0 . put( ERROR_MESSAGE ) ; 

TEXT_I0 . put( " at line number "); 

TEXT_I0. put( positive’ IMAGE( TM . LINES_CHECKED) ) ; 

TEXT_IO . new_l i ne( 2 ) ; 
raise PARSERERROR ; 
end SYNTAX_ERROR ; 

procedure 0UT_PUT ( FUNCTION_NAME : in string) is 
T0P_T0KEN : TOKEN_SCANNER.TOKEN_RECORD_TYPE; 
use TEXT_IO , TOKEN_SCANNER ; 
begin 

TOKEN_MATCHER.CURRENT_TOKEN(TOP_TOKEN); 
put( FUNCTION_NAME ) ; set_col(40); 

if ( TOP_TOKEN . TOKEN_TYPE /= TOKEN_SCANNER . EOF ) then 
for LEXEME INDEX in 1. . TOP_TOKEN . LEXEME_SIZE loop 
put( T0P_T0KEN . LEXEME ( LEXEME_INDEX ) ) ; 
end loop; 
end if; 

new_line; set_col(4Q); 

put_l i ne( TOKEN_SCANNER . TOKEN_CLASS ' IMAGE ( TOP_TOKEN . TOKEN_TYPE ) ) ; 
end 0UT_PUT ; 

end PARSER_4 ; 
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APPENDIX 1) 



"ADAFLOW” PKOGRAM LISTING ■ NET GENERATOR 



TITLE: 


ADAFLOW 


-- 


MODULE NAME: 


PACKAGE NET_GENERATOR 


-- 


FILE NAME: 


NET. AOS 


-- 


DATE CREATED: 


12 


MAR 88 


-- 


LAST MODIFIED: 


: 28 


APR 88 


-- 


AUTHOR(S) : 


LT 


ALBERT J. GRECCO, USN 


- 


DESCRIPTION: 


This 


package contains the procedures which 


-- 



define the interface to the net generator. 



with SYMBOL_TABLE; 



package NET_GENERATOR is 



NET_GENERATOR_OVERFLOW : exception; 



procedure START( RUNUNITNAME : in SYMBOL_TABLE . SYM_TAB_ACCESS ) ; 

-- post - Defines a either a subprogram place or task place that has 
an initial marking in the petri net model 

procedure OECISION_START(START_PLACE : in positive; 

END_PLACE : in SYMBOL_TABLE . SYM_TAB_ACCESS ) ; 
-- post - Defines a place that is the root place of a multi-way decision 
path and it's correspondi ng end label. 



procedure DECISION_OR( END_PATH_PLACE : in positive); 

-- post - Ends the current path of a multi-way decision and starts the 
next path. The decision start place is reactivated as the 
current block number. 



procedure EXPLICIT_DECISION_OR; 

-- post - Ends the current path of a multi-way decision and starts the 
next path. The decision start place is reactivated as the 
current block number. 
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procedure 
-- post - 

procedure 
-- post - 

procedure 
-- pre - 
-- post - 
procedure 
-- pre 

— post - 
procedure 

— post - 
procedure 
-- post - 

procedure 
-- post - 

procedure 
-- post - 
procedure 
-- post - 
procedure 
-- post - 

p rocedure 
-- post - 



END_DECISION(END_PATH_PLACE : in positive); 

Ends the current path of a multi-way decision and terminates 
the multi-way decision. 

EXPLICIT_END_DECISION ; 

Ends the current path of a multi-way decision and terminates 
the multi-way decision. 

CALL(CURRENT_L0CATI0N : in positive; 

PROCEDURE_LOCATION : in SYMBOL_TABLE . SYM_TAB_ACCESS) ; 

The procedure location must be the current entry in the 
symbol table. 

The abstract grammar for a procedure call is generated. 

ENTRY_CALL(CURRENT_LOCATION : in positive; 

ENTRYLOCATION : in SYMBOL_TABLE . SYM_TAB_ACCESS) ; 
The entry location must be the current entry in the 
symbol table. 

The abstract grammar for a task entry is generated. 

TASK_ACCEPT(CURRENT_LOCATION : in positive; 

ENTRYLOCATION : in positive); 

The abstract grammar for a task accept is generated. 

END_ACCEPT(CURRENT_LOCATION : in positive; 

ENTRYEND : in positive); 

The abstract grammar for the end of an accept statement is 
generated . 

EXPLICIT_END_ACCEPT ( ENTRY_END : in positive); 

The abstract grammar for the end of an accept statement is 
generated . 

GO_TO(CURRENT_LOCATION : in positive; 

GO_TO_LOCATION : in SYMBOL_TABLE . SYM_TAB_ACCESS ) ; 

The abstract grammar for a goto statement is generated. 

END_LOOP(END_LOCATION : in positive; 

LOOP_START : in SYMBOL_TABLE . SYMTABACCESS ) ; 

The abstract grammar for a loop is generated. 

CONNECT_BLOCKS( CURRENT_L0CATI0N : in positive; 

NEXT_LOCATION : in positive); 
used to explicitly declare a transition between two known 
code blocks. The abstract grammar for a transition between 
two petri net places is generated. 

EXPLICIT_END( NEXTLOCATION : in positive); 

The current forest is terminated and a new forest is begun. 



155 



procedure TRANSLATE_TO_PEANUT ; 

-- post - used to translate the abstract petri net grammar to a 

text file used as an input file to P-NUT petri net analyzer. 
Produces two files: 1) a. out - P-NUT input file 

2) place.dat - text file that describes all 
the places that exist in the 
petri net and/or the 
places relation to the 
original source code. 

The net generator and code blocker are reset to their 
initial states. 

procedure RESET_NET_GENERATOR ; 

-- post - The net generator is returned to it's initial state, 
end NET_GENERATOR; 



156 



TITLE: 



ADA FLOW 



-- MODULE NAME: PACKAGE NETGENERATOR 

-- FILE NAME: NET.ADB 



-- DATE CREATED: 12 MAR 88 

-- LAST MODIFIED: 28 APR 88 



— AUTHOR(S): LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package contains the procedures which 

implement the interface to the net generator. 



with TOKEN_SCANNER, 

GENERIC_LIST, 

GENERIC_STACK , 

UNCHECKED_DEALLOCATION, 

SYMBOL_TABLE , 

CODE_BLOCKER , 

TEXT_I0 , 

IO_EXCEPTIONS; 

package body NET_GENERATOR is 

DUMMY_SOURCE : TOKEN_SCANNER . SOURCE_RECORD ; 

type PETRI_IDENTIFI ERTYPE is (PLACE, TRANSITION); 

type LIST_NODE is 
record 

PETRITAG : PETRI_IDENTI F I ER_TYPE ; 

SYMBOL : SYMBOLTABLE . SYM_TAB_ACCESS := null; 
end record; 



type LIST_NODE_POINTER is access LI ST_NODE ; 

package NEST_STACK is new GENERIC_STACK( LI ST_NODE_PO INTER) ; 
NS : NEST_STACK. STACK; 

TRANSITION_POINTER : LI ST_NODE_POINTER ; 

DECISIONROOT : LISTNODEPOINTER := null; 

DECISION_TAIL : LI ST_NODE_PO INTER := null; 

package ABSTRACT_SYNTAX_LIST is 

type LIST INSTANCE is private; 
type LIST is access LI STINSTANCE ; 
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L I ST OV ERF LOW : exception; 

LISTUNDERFLOW : exception; 

Operations: If the list is not empty, then one of the nodes is designated 

as the current node. Ocaas ional ly , in the postcondition, it is necessary 
to refer to the list of the current node as they were immediately before 
execution of the operation. L-pre and c-pre, respectively, are employed 
for these references. 

procedure FIND_FIRST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure FIND_NEXT( L : in out LIST); 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LISTJJNDERFLOW if L is empty. 

- LISTOVERFLOW if the last node is the current node. 

procedure FIND_PREVI0US( L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 

procedure FIND_LAST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure RETRIEVE^ : in LIST; ITEM ; out LIST_NODE_POINTER) ; 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

procedure UPDATE(L : in out LIST; ITEM : in LIST_NODE_POINTER) ; 

-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LIST_UNOERFLOW if L is empty. 

procedure INSERT ( L : in out LIST; ITEM : in LIST_N0DE_P0INTER) ; 

-- pre - The number of nodes in L has not reached its bound. 

post - A node containing ITEM is the last node in the list, and the last 

node in L-pre, if any, is its predecessor. The node containing 

ITEM is the current node. 

exceptions raised - LIST OVERFLOW if L has reached its bound. 

procedure DELETE(L ; in out LIST); 
pre - The list L is not empty. 

post - c-pre in not in the list L. If c-pre was the first node, 
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then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 



function SIZE_0F(L : in LIST) return natural; 

-- post - SIZE_0F is the number of nodes in list L. 



function EMPTY { L : in LIST) return boolean; 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 



function FULL(L : in LIST) return boolean; 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 

function FIRST(L : in LIST) return boolean; 

— pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 



function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 



procedure CREATE( L : in out LIST; SUCCESS : out boolean); 

— post - If a list L can be created then L exists and is empty, 
is TRUE else SUCCESS is FALSE. 



and SUCCESS 



procedure DISPOSE(L : in out LIST); 
— post - L-pre does not exist. 

private 

type NODE; 

type NODEPOINTER is access NODE; 
type NODE is 
record 

ELEMENT : LIST_NODE_POINTER ; 
NEXT : NODEPOINTER; 
end record; 
type LI ST_INSTANCE is 



record 






HEAD 


: NODE_POINTER 


: = nul 


TAIL 


: NODE_POINTER 


: = nul 


CURRENT 


: NODEPOINTER 


: = nul 


SIZE 


: natural := 0; 





end record; 
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end ABSTRACT_SYNTAX_LIST; 

package F0REST_LIST is new GENERIC_LIST(ABSTRACT_SYNTAX_LIST .LIST) ; 



FOREST : FOREST_LIST . LIST; 

START_SYNTAX : ABSTRACT_SYNTAX_LIST . LIST ; 
STOP_PLACES : ABSTRACT_SYNTAX_LIST . LIST ; 

package body ABSTRACT_SYNTAX_LIST is 



procedure FREE_NODE is new UNCHECKED_DEALLOCATION{ NODE , NODE_POINTER ) ; 
procedure FREE_LIST is new UNCHECKED_DEALLOCATION( LIST_INSTANCE , LIST); 
procedure FREESYMREC is new UNCHECKED_DEALLOCATION( SYMBOL_TABLE . 

SYM_TAB_RECORD , 

SYMBOL_TABLE. 

SYM_TAB_ACCESS); 



procedure FIND_FIRST(L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LI ST_UND£RFLOW if L is empty, 
begin 

if (EMPTY(L)) then 
raise LlST_UNDERFLOW ; 

end if; 

L. CURRENT := L , HEAD; 
end FINDFIRST; 



procedure FIND_NEXT(L : in out LIST) is 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

- LIST_OVERFLOW if the last node is the current node. 

begin 

if (EMPTY(L) ) then 
raise LIST_UNDERFLOW ; 
end if; 

if (LAST(L)) then 
raise LISTOVERFLOW; 
end if; 

L. CURRENT := L .CURRENT . NEXT ; 
end FINDNEXT; 

procedure FIND_PREVIOUS( L : in out LIST) is 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 

TEMP_POINTER : NODE_POI NTER ; 
beg i n 

if ( EMPTY ( L ) or FIRST(L)) then 
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raise LIST_UNDERFLOW; 
end if; 

TEMP_POINTER := L .HEAD; 

while ( TEMP_POINTER .NEXT /= L. CURRENT) loop 
TEMP_P0INTER := TEMP_POINTER . NEXT ; 
end loop; 

L. CURRENT := TEMP_POINTER; 
end FINDPREVIOUS; 

procedure FIND_LAST { L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if ( EMPTY ( L ) ) then 

raise LIST_UNDERFLOW ; 
end if; 

while (not LAST ( L ) ) loop 
FIND_NEXT (L) ; 
end loop; 
end FIND_LAST; 

procedure RETRIEVE^ : in LIST; ITEM : out LIST_NODE_POINTER) is 
-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

-- exceptions raised - LISTJJNDERFLOW if L is empty, 
begin 

if (EMPTY(L) ) then 
raise LIST_UNDERFLOW; 
end if; 

ITEM := L. CURRENT. ELEMENT; 
end RETRIEVE; 

procedure UPDATE( L : in out LIST; ITEM : in LIST_NOOE_POINTER) is 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
begin 

if (EMPTY(L) ) then 
raise LISTJJNDERFLOW; 
end if; 

L. CURRENT. ELEMENT := ITEM; 
end UPDATE; 

procedure INSERT ( L : in out LIST; ITEM : in LIST_NODE_POINTER) is 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 

node in L-pre, if any, is its predecessor. The node containing 

ITEM is the current node. 

-- exceptions raised - LISTOVERFl OW if L has reached its bound. 
TEMPPOINTER : NODEPOINTER ; 
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use SYMBOL_TABLE ; 
begin 

if (FULL(L)) then 
raise Ll$T_OVERFLOW; 
end if; 

TEMP_POINTER := new NODE ' ( ITEM, null); 

TEMP_POINTER. ELEMENT .SYMBOL .REFERENCE_COUNT : = 

natural ’ SUCC( TEMP_P0INTER . ELEMENT . SYMBOL . REFERENCE_COUNT ) ; 
if (L.HEAD = null) then 
L .HEAD := TEMP_POINTER ; 

L.TAIL ;= TEMP_POINTER; 
else 

L.TAIL. NEXT ;= TEMP_POINTER ; 

L.TAIL := TEMP_POINTER; 

end if; 

L. CURRENT := TEMP_POINTER ; 

L.SIZE := L . SIZE + 1; 
end INSERT; 

procedure DELETE(L ; in out LIST) is 
-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

TEMP_POINTER : NODE_POINTER; 

use SYMBOL_TABLE; 

begin 

if ( EMPTY ( L ) ) then 

raise LIST_UNDERFLOW; 
end if; 

if (L. CURRENT /= L.HEAD) then 
TEMPPOINTER := L.HEAD; 

while ( TEMP_POINTER .NEXT /= L. CURRENT) loop 
TEMP_POINTER := TEMP_P0INTER . NEXT ; 
end loop; 

TEMPPOINTER.NEXT := L . CURRENT . NEXT ; 
if (L. CURRENT = L.TAIL) then 
L.TAIL := TEMPPOINTER ; 
end if; 
el se 

if (L.HEAD = L.TAIL) then 
L.TAIL := null; 
end if; 

L.HEAD := L.HEAD. NEXT; 
end if; 

if (L. CURRENT. ELEMENT. SYMBOL. REFERENCE COUNT > 1) then 
L. CURRENT. ELEMENT. SYMBOL. REFERENCE_COUNT := 

posi tive'PRED(L. CURRENT. ELEMENT. SYMBOL. REFERENCE_COUNT ) ; 

el se 

FREE_SYM_REC(L. CURRENT. ELEMENT. SYMBOL); 
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end if; 

FREE_NODE(L. CURRENT); 

L. CURRENT := L . TAIL ; 

L . SIZE := L . SIZE - 1; 
end DELETE; 

function SIZE_OF(L : in LIST) return natural is 
-- post - SIZE_0F is the number of nodes in list L. 
begin 

return (L.SIZE); 
end SIZE_0F ; 

function EMPTY( L : in LIST) return boolean is 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 

begin 

return (L.HEAD = null); 
end EMPTY; 

function FULL(L : in LIST) return boolean is 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 

TEMP_POI NTER : NODE_POINTER ; 
begin 

TEMP_POINTER := new NODE; 

FREE_N0DE( TEMP_POINTER ) ; 
return (FALSE); 
exception 

when STORAGE_ERROR => 
return (TRUE); 
when others => 
rai se ; 
end FULL; 

function FIRST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
begin 

if ( EMPTY(L) ) then 
raise LISTJJNDERFLOW; 
end if; 

return (L. CURRENT = L.HEAD); 
end FIRST; 

function LAST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

- exceptions raised L I STUNDERFLOW if L is empty. 
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begin 

if (EMPTY(L)) then 
raise LI ST_UNDERFLOW; 
end if; 

return (L. CURRENT = L.TAIL); 
end LAST; 



procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

begin 

L := new LIST_INSTANCE '(null, null, null, 0); 

SUCCESS := TRUE; 
exception 

when STORAGE_ERROR => 

SUCCESS := FALSE; 
when others => 
rai se ; 
end CREATE; 

procedure DISPOSE(L : in out LIST) is 
-- post - L-pre does not exist, 
begi n 

if (not EMPTY ( L ) ) then 
FINDLAST(L); 
while (not EMPTY(L) ) loop 
DELETE(L); 
end loop; 
end if; 

FREE_LIST(L) ; 
end DISPOSE; 

end ABSTRACT_SYNTAX_LIST ; 

function CREATE_DUMMY_PLACE ( LABEL : in string) 

return LIST_NODE_POINTER is 

-- post - a place is created with a unique code block number and given 
a tag denoted by LABEL. CREATE_DUMMY_PLACE returns a pointer 
to a syntax list node that now contains this place. 

LOCATION : positive; 

TEMPPOINTER : LIST_NODE_POINTER ; 
begin 

CODE_BLOCKER . ENTER_CODE_BLOCK( DUMMYSOURCE , LABEL) ; 

LOCATION := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 

CODE_BLOCKER . EXI T_CODE_BLOCK( DUMMYSOURCE ) ; 

TEMP_POINTER := new LIST_NODE ; 

TEMP_POINTER . PETRI TAG := PLACE; 

TEMPPOINTER. SYMBOL := new SYMBOLTABLE . SYMTABRECORD ; 

TEMP_POINTER. SYMBOL. NAME := (others => 1 ’); 

TEMPPOINTER. SYMBOL. NAME LENGTH := 0; 

TEMPPOINTER. SYMBOL .LOCATION : = LOCATION; 
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TEMP_PO INTER . SYMBOL . REFERENCE_COUNT := 0; 
return ( TEMPPOINTER ) ; 
exception 

when STORAGE_ERROR => 

raise NET_GENERATOR_OVERFLOW ; 
when others => 
raise; 

end CREATE_DUMMY_PLACE ; 

function NUMBER_TO_LIST_NODE(CURRENT_LOCATION : in positive) 

return LIST_NODE_POINTER is 

-- post - NUMBER_TO_LIST_NODE returns a pointer 

to a syntax list node that now contains this place. 

TEMP_POINTER : LI ST_NODE_POI NTER ; 
begin 

TEMP_POINTER := new LISTNODE; 

TEMPPOINTER.PETRITAG := PLACE; 

TEMP_POINTER. SYMBOL := new SYMBOL_TABLE . SYM_TAB_RECORD ; 

TEMP_POINTER. SYMBOL. NAME := (others => ’ ’); 

TEMP_POINTER. SYMBOL. NAME_LENGTH := 0; 

TEMP_POINTER. SYMBOL. LOCATION CURRENT ^LOCATION ; 

TEMP_POINTER . SYMBOL . RE FERENC E_COUNT := 0; 
return ( TEMP_POINTER) ; 
exception 

when ST0RAGE_ERR0R => 

raise NET_GENERATOR_OVERFLOW ; 
when others = > 
raise; 

end NUMBER_TO_LIST_NODE ; 

function POINTER_TO_LIST_NODE( LOCATION : in SYMBOLTABLE . SYM_TAB_ACCESS ) 

return LIST_NODE_POINTER is 

-- post - POINTER_TO_LIST_NODE returns a pointer 

to a syntax list node that now contains this place. 

TEMP_POINTER : LIST_NODE_POINTER ; 
begin 

TEMP_POINTER ;= new LIST_NODE ; 

TEMP_POINTER . PETRI_TAG := PLACE; 

TEMP_POINTER. SYMBOL ;= LOCATION; 
return ( TEMPPOINTER ) ; 
exception 

when STORAGE_ERROR => 

raise NET_GENERATOR_OVERFLOW ; 
when others => 
raise; 

end POINTER_TO_LIST_NODE ; 
procedure NEW_SYNTAX_LIST is 

-- pre - The forest size has not reached it's bound. 

-- post - An empty syntax list is inserted into the forest and becomes the 
current element in the forest. 
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TEMPSYNTAX : ABSTRACT_SYNTAX_LIST .LIST; 

SUCCESS : boolean; 
begin 

ABSTRACT_SYNTAX_LIST . CREATE ( TEMP_SYNTAX , SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW ; 
end if; 

if (not F0REST_LIST . FULL( FOREST) ) then 
FOREST_LIST . INSERT ( FOREST , TEMP_SYNTAX ) ; 
else 

raise NET_GENERATOR_OVERFLOW ; 
end if; 

end NEW_SYNTAX_LIST ; 

procedure INITIALIZE_NET_GENERATOR is 

SUCCESS : boolean; 

begin 

DUMMY_SOURCE . FI LE_NAME := (others = > ’ ’); 

DUMMY_SOURCE . FI LE_NAME_SIZE ;= 0; 

DUMMY_S0URCE.LINE_NUMBER := 0; 

ABSTRACT_SYNTAX_LIST . CREATE ( START_SYNTAX , SUCCESS); 

if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW; 
end if; 

ABSTRACT_SYNTAX_LIST . INSERT ( START_SYNTAX , 

CREATE_DUMMY_PLACE( "START" ) ) , 
TRANSI TION_POINTER := new LIST_NOOE; 
TRANSITION_POINTER.PETRI_TAG := TRANSITION; 

TRANSIT I0N_P0INTER . SYMBOL := new SYMBOL_TABLE . SYM_TAB_RECORD ; 
TRANSITION_POINTER. SYMBOL. NAME ;= (others => ' ’); 

TRANSI TION_POINTER . SYMBOL . NAME_LENGTH ;= 0; 

TRANSITION_POINTER. SYMBOL. LOCATION ;= 0; 

TRANSITIONPOINTER. SYMBOL. REFERENCE_COUNT := 0; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, TRANSITION_POINTER ) ; 
ABSTRACT_SYNTAX_LIST . CREATE ( STOP_PLACES , SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW; 
end if; 

FOREST_LIST . CREATE ( FOREST, SUCCESS) ; 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW ; 
end if; 

NESTSTACK . CREATE ( NS , SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW ; 
end if; 

NEWSYNTAXLIST; 

exception 

when STORAGE_ERROR => 

raise NET GENE RATOROVER FLOW ; 
when others => 
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raise; 

end INITI ALI ZE_NET_GENERATOR ; 
procedure RESET_NET_GENERATOR is 

-- post - The net generator is returned to it's initial state. 
TEMP_ASL : ABSTRACT_SYNTAX_LIST . LIST ; 

SUCCESS : boolean; 
begin 

ABSTRACT_SYNTAX_LIST . DISPOSE ( START_SYNTAX ) ; 
if (not FOREST_LIST . EMPTY ( FOREST ) ) then 
F0REST_LIST . FIND_LAST( FOREST) ; 
while (not FOREST_LIST . EMPTY ( FOREST ) ) loop 
FOREST_LIST .RETRIEVE (FOREST, TEMPASL); 
ABSTRACT_SYNTAXJ_IST.DISPOSE(TEMP_ASL); 

FOREST_LIST .DELETE( FOREST ) ; 
end loop; 
end if; 

ABSTRACT_SYNTAX_LIST . DI SPOSE ( STOP_PLACES ) ; 
ABSTRACT_SYNTAX_LIST. CREATE ( START_SYNTAX , SUCCESS); 
if (not SUCCESS) then 

raise NE T_GENERAT0R_0VERFL0W; 
end if; 

ABSTRACT_SYNTAX_LIST.CREATE(STOP_PLACES, SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW; 
end if; 

ABSTRACT_SYNTAX_LIST .INSERT ( START_SYNTAX , 

CREATE_DUMMY_PLACE( "START" ) ) ; 
TRANSITI0N_P0INTER := new LI ST_NODE ; 

TRANSITION_POINTER . PETRI_TAG := TRANSITION; 

TRANSITIONPOINTER. SYMBOL ;= new SYMBOL_TABLE . SYM_TAB_RECORD ; 
TRANSITION_POINTER. SYMBOL. NAME := (others => ' '); 
TRANSITION_POINTER. SYMBOL. NAME_LENGTH := 0; 

TRANSITI0N_P0INTER. SYMBOL. LOCATION ;= 0; 

TRANSITION_POINTER . SYMBOL . RE FERENCE_COUNT := 0; 
ABSTRACT_SYNTAX_LIST . INSERT ( START_SYNTAX , TRANSITION_POINTER) ; 
NEW_SYNTAX_LIST; 
end RESET_NET_GENERATOR; 



function IS_COMPLETE return boolean is 

-- post - If the current syntax list in the forest is empty, then 

IS_COMPLETE returns true, else ISCOMPLETE returns false. 
TEMP_SYNTAX : ABSTRACT_SYNTAX_LIST . LIST ; 
begin 

FOREST_LIST . RETRIEVE ( FOREST, TEMPSYNTAX ) ; 
return ( ABSTRACT_SYNTAX_LIST . EMPTY( TEMP_SYNTAX ) ) ; 
end IS_COMPLETE; 

procedure INSERT_FOREST ( TRANS OR PLACE : in LIST NODE POINTER ) is 
-- post - The specified transition or place is inserted into the forest 
in the current syntax list. 



167 



UM p LIST : MST»Ct.S*««> 1ST - LI8T - 
TtMP ' 

- - S£RT ' F0RES1; ^ SVMBOtJABU.S^^f^; p a s 

START(^ n - UN1T ' ‘horogram place or ta 

procedure S e ither a su P model. 

- post - “ ef ’" eS t . a al „, ark io9 tne petr 

- , T ; o V ^- N0Dt -TsvM R ^B access: 

RUN.UNlT.NOOe • B0L TABte.STM.TAB- 

’ oner RUN UNH_ NftMt ^’ 

begin . - P 0 lNlER_ T0 - LlST ' N Nm ~RUN_ uNlT - N00t )• 

RUN.UNU.N00t ' » 1NSt R 1(S TART.SVNTAT 

ENO.WABNtB .- C0MP0 N£NT (**«>■> : 

^e,esTORe^eNT,NTBT ! 

e«U START; positive; ACCESS) ^ 

; --sr-fSU 

teg'" oiiRHlNSt DtClSlON.ROO^' 

REST. ST ACT OECISTON.TAT pLACE); 

decision .tail 

end OtCISlON.ST • ^ positive) is starts t»e 

r^.S’=r®‘- :=;r " :: 

ne rrent'tloct number. 

nf CU list nooe.pointer; 

s ™f„' ‘ ' ,0 list NOoeceND.PATH-PCACt); 

669 , uflDE - NUMBtR.TO.LTS . 

START.NODt ■ ^ ttie „ 

^^RESTlSTART.NOOe); 

NEW SYNTAX .LIST. 

Insert” tore st (Decision. tail) ; 

reu.syntax.list; 



P r< 



168 



CODEBLOCKER . REACTIVATE_CODE_BLOCK( DECI SI ON_ROOT . SYMBOL . LOCATION ) ; 
end DECISION_OR ; 

procedure EXPLICIT_DECISION_OR is 

-- post - Ends the current path of a multi-way decision and starts the 
next path. The decision start place is reactivated as the 
current block number. 

beg i n 

if (not IS_COMPLETE ) then 

INSERT_FOREST (DECISI0N_TAIL) ; 

NEW_SYNTAX_LIST; 

CODE_BLOCKER . REACTIVATE_CODE_BLOCK( DECISION_ROOT . SYMBOL . LOCATION ) ; 
end if; 

end EXPLICI T_DEC I SI ON OR ; 

procedure END_DECISION( ENDPATHPLACE : in positive) is 
-- post - Ends the current path of a multi-way decision and terminates 
the multi-way decision. 

START_NODE : LIST_NODE_POI NTER ; 
begin 

START_NODE := NUMBER_TO_LIST_NODE( END_PATH_PLACE ) ; 
if (not IS_COMPLETE ) then 
INSERT_FOREST(START_NODE); 

NEW_SYNTAX_LI ST ; 
end if; 

INSERT_FOREST(START_NODE) ; 

I NSERT_FOREST( TRANSIT I ON_POI NTER) ; 

INSERT_FOREST(DECISION_TAIL) ; 

NEW_SYNTAX_LIST; 

INSERT_F0REST(DECISI0N_TAIL) ; 

INSERT_FOREST( TRANS I TION_POI NTER) ; 

NEST_STACK . POP ( NS, DECISION_TAIL) ; 

NEST_STACK . POP ( NS, DECI SION_ROOT ) ; 
end END_DECISION ; 

procedure EXPLICIT_END_DECISION is 

-- post - Ends the current path of a multi-way decision and terminates 
the multi-way decision. 

begin 

if (not IS_COMPLETE) then 

INSERTFOREST(DECISIONTAIL); 

NEW_SYNTAX_LIST; 
end if; 

INSERT_FOREST( DECISION TAIL); 

I NSERTFOREST ( TRANSI T IONPOI NTER ) ; 

NEST_STACK.POP(NS, DECISION_TAlL ) ; 

NEST_STACK . POP(NS, DECISION ROOT) ; 
end EXPLICI T_END_DECISION ; 

procedure CALL(CURRENT_ LOCATION : in positive; 

PROCEDURE_LOCAT ION : in SYMBOL_IABLE . SYM_TAB_ACCESS ) is 
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-- pre - The procedure location must be the current entry in the 
symbol table. 

-- post - The abstract grammar for a procedure call is generated. 
START_NODE : LIST_NODE_POINTER ; 

WAIT_N0DE : LIST_NODE_POINTER; 

TEMP_P0INTER : SYMBOL_TABLE . SYM_TAB_ACCESS ; 
begin 

START_NODE := NUMBER_TO_LI ST_NODE ( CURRENT_LOCATION ) ; 

WAI T_NODE := CREATE_DUMMY_PLACE ("WAIT RETURN"); 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 

TEMPPOINTER := SYMBOL_TABLE . SELECT_COMPONENT( ’’END" ) ; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
if (not IS_COMPLETE ) then 
INSERT_FOREST(START_NODE); 

NEW_SYNTAX_LIST; 
end if; 

INSERT_FOREST(START_NODE); 

INSERT_FOREST( TRANSIT I ON_POINTER) ; 

I NSERT_FOREST ( POI NTER_TO_LI ST_NODE ( PROCEDURE_LOCATION ) ) ; 
INSERT_FOREST(WAIT_NODE); 

NEW_SYNTAX_LIST; 

INSERT_FOREST(WAI T_NO0E ) ; 

I NSERT_FOREST ( POI NTER_TO_LIST_NODE( TEMP_POINTER) ) ; 

INSERT_FOREST ( TRANSIT I ON_POINTER) ; 
end CALL; 

procedure ENTRY_CALL(CURRENT_LOCATION : in positive; 

ENTRY_LOCATION : in SYMBOL_TABLE . SYMTABACCESS ) is 
-- pre - The entry location must be the current entry in the 
symbol table. 

-- post - The abstract grammar for a task entry is generated. 

START_NODE : LISTNODEPOINTER; 

WAI T_NODE : LlST_NODE_POINTER; 

TEMPPOINTER : SYMBOL_TABLE . SYM_TAB_ACCESS; 
begin 

START_NODE ;= NUMBERTOLI ST_NODE ( CURRENT_LOCATION ) ; 

WAI T_NODE := CREATE_DUMMY_PLACE( "WAI T RENDEZVOUS"); 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 

TEMP_POINTER := SYMBOLTABLE . SELECT_COMPONENT( "END" ) ; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
if (not I S_COMPLETE ) then 
I NSERT_FOREST ( STARTNODE ) ; 

NEW_SYNTAX_LIST; 
end if; 

INSERT_F0REST( START_NODE ) ; 

INSERT_FOREST( TRANSI T ION_POI N TER ) ; 

INSERT_FOREST( POI NTER_TO_L I ST NODE ( ENTRY_LOCATI ON ) ) ; 

INSERT FOREST (WAIT NODE); 

NEWSYNTAX LIST ; 

INSERT FOREST(WAIT NODE ) ; 

INSERTF OR EST(P0 INTER! OLIS1 NODE ( TEMPPOI NTER ) ) ; 
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I N SE R T_FOR E ST ( TRANSIT IONPOINTER ) ; 
end ENTRY_CALL ; 

procedure TASK_ACCEPT (CURRENTLOCAT ION : in positive; 

ENTRYLOCATION : in positive) is 
-- post - The abstract grammar for a task accept is generated. 
START_NODE : LIST_NODE_POINTER; 
begin 

STARTNODE := NUMBER_TO_LIST_NODE(CURRENT_LOCATION ) ; 
if (not IS_COMPLETE) then 
INSERT_FOREST(START_NODE); 

NEW_SYNTAX_LIST ; 
end if; 

INSERT_FOREST(START_NODE) ; 

INSERT_FOREST(NUMBER_TO_LIST_NODE( ENTRY_LOCATION ) ) ; 

INSERT_FOREST ( TRAN SI TIONPOINTER ) ; 
end TASK_ACCEPT ; 

procedure END_ACCEPT(CURRENT_LOCATION ; in positive; 

ENTRY_END : in positive) is 

-- post - The abstract grammar for the end of an accept statement is 
generated. 

CURRENT_NODE : LIST_NODE_POINTER ; 

LOOP_POI NTER ; SYMBOL_TABLE . SYM_TAB_ACCESS ; 
begin 

CURRENT_NODE := NUMBER_TO_LIST_NODE(CURRENT_LOCATION) ; 
if (not I S_COMPLETE ) then 
INSERT_FOREST(CURRENT_NODE) ; 

NEW_SYNTAX_LIST; 
end if; 

INSERT_FOREST(CURRENT_NODE); 

INSERT_FOREST( TRAN SI TION_POINTER) ; 

INSERT_F0REST ( NUMBER_TO_LI ST_NODE( ENTRY_END ) ) ; 
end END_ACCEPT ; 

procedure EXPLICI T_END_ACCEPT ( ENTRY_END : in positive) is 
-- post - The abstract grammar for the end of an accept statement is 
generated. 

begin 

if (not IS_COMPLETE ) then 

INSERT_FOREST(NUMBER_TO_LIST_NODE(ENTRY_END) ) ; 
end if; 

end EXPLIC I T_END_ACCEPT ; 

procedure GO_TO(CURRENT_LOCATION : in positive; 

G0_T0_L0CATI0N : in SYMBOL_TABLE . SYMTABACCESS ) is 
-- post - The abstract grammar for a goto statement is generated. 
STARTNODE : LIST_NODE ^POINTER ; 
begin 

STARTNODE := NUMBE R TO L I ST NODE ( CURRENT LOCATION ) ; 
if (not ISCOMPLETE ) then 
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INSERT_FOREST( START_NODE ) ; 

NEW_SYNTAX_LI ST ; 
end if; 

INSERT_FOREST(START_NODE ) ; 

INSERT_F0REST ( TRANSI TION_POINTER) ; 

INSERT_FOREST( POINTER_TO_LIST_NODE (GO_TO_LOCATION ) ) ; 

NEW_SYNTAX_LIST; 
end 60_T0; 

procedure END_LOOP( END_LOCATION : in positive; 

L00P_START : in SYMBOL_TABLE . SYM_TAB_ACCESS ) is 
-- post - The abstract grammar for a loop is generated. 

END_N0DE : LIST_NODE_POINTER ; 

L00P_P0INTER : SYMBOL_TABLE . SYM_TAB_ACCESS; 
begin 

ENDJJODE := NUMBER_TO_LIST_NODE( END_L0CATI0N ) ; 
if (not IS_COMPLETE ) then 
INSERT_FOREST ( END_N0DE ) ; 

NEW_SYNTAX_LIST ; 
end if; 

INSERT_FOREST( ENDJJODE ) ; 

INSERT_FOREST ( TRANSI T I ON_PO INTER ) ; 
INSERT_FOREST(POINTER_TO_LIST_NODE(LOOP_START)); 
end EN0_L00P; 

procedure CONNECT_BLOCKS(CURRENT_LOCATION : in positive; 

NEXTLOCATION : in positive) is 
-- post - used to explicitly declare a transition between two known 

code blocks. The abstract grammar for a transition between 
two petri net places is generated. 

STARTNODE : LIST_NODE_POINTER; 
begin 

START_NODE := NUMBER_TO_LIST_NODE ( CURRENT_LOCATION ) ; 
if (not IS_COMPLETE ) then 
INSERT_FOREST(START_NODE ) ; 

NEW_SYNTAX_LIST; 
end if; 

INSERT_F0REST( START_NODE ) ; 

INSERT_FOREST ( TRANSI TI0N_P0INTER ) ; 
INSERT_FOREST(NUMBER_TO_LIST_NODE(NEXT_LOCATION)); 

NEW_SYNTAX_LIST ; 
end CONNECT_BLOCKS; 

procedure EXPLICI T_END( NEXT_LOCATION ; in positive) is 
-- post - The current forest is terminated and a new forest is begun, 
begin 

if (not I S_COMPLE TE ) then 

INSERT_FOREST( NUMBER_TO_L I STNODE ( NEXT_LOCAT ION ) ) ; 

NEW_SYNTAX LIST; 
end if; 

end EXPLICITEND; 
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procedure TRANSLATE_TO_PEANUT is 

-- post - used to translate the abstract petri net grammar to a 

text file used as an input file to P-NUT petri net analyzer. 
Produces two files: 1) a. out - P-NUT input file 

2) place.dat - text file that describes all 
the places that exist in the 
petri net and/or the 
places relation to the 
original source code. 

The net generator and code blocker are reset to their 
initial states. 

TRANSIT I ON_NUMBER : positive := 1; 

NET_FILE : TEXT_IO . f i 1 e_type ; 

SYNTAX_LIST : ABSTRACT_SYNTAX_LIST . LIST; 

INITIAL_MARK : LIST_NODE_POINTER ; 

PLACE_FILE : TEXT_I0 . f i 1 e_type ; 

START_SOURCE_INFO : TOKEN_SCANNER . SOURCE_RECORD ; 

STOP_SOURCE_INFO : TOKEN_SCANNER . SOURCE_RECORD ; 

function P0S_T0_LIT( NUMBER : string) return string is 
begin 

return ( NUMBER( 2 .. NUMBER ' LAST )) ; 
end P0S_T0_LIT; 

procedure XLATE(SYNTAX_LIST : in out ABSTRACT_SYNTAX_LIST .LIST) is 
package PLACE_STACK is new GENERIC_STACK( LI ST_N00E_P0 INTER) ; 

TEMP_POINTER : LIST_NOOE_POINTER ; 

PS : PLACE_STACK. STACK; 

SUCCESS : boolean; 
begin 

PLACESTACK .C REATE ( PS, SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_OVERFLOW; 
end if; 

if (not ABSTRACT_SYNTAX_LIST . EMPTY ( SYNTAX_LIST) ) then 
ABSTRACT_SYNTAX_LIST.FINO_FIRST(SYNTAX_LIST); 

ABSTRACT_SYNTAX_LIST . RETRIEVE(SYNTAX_LIST , TEMPPOINTER ) ; 
while ( TEMP_POINTER . PETRI_TAG /= TRANSITION) loop 
PLACE_STACK . PUSH( PS , TEMP_POINTER) ; 

ABSTRACT_SYNTAX_LIST . FIND_NEXT ( SYNTAX_LIST ) ; 
ABSTRACT_SYNTAX_LIST.RETRIEVE(SYNTAX_LIST, TEMPPOINTER ) ; 
end loop; 

ABSTRACT_SYNTAX_LIST.FIND_NEXT(SYNTAX_LIST); --skip transition pointer 
TEXT_IO.put( NET_FI LE , ":t"); 

TEXT_IO.put(NET_FILE, POS_TO_LIT( pos i t i ve ’ IMAGE ( TRANSIT IONNUMBER ) ) ) ; 
TRANSITION_NUMBER := TRANSI T IONNUMBER + 1; 

TEXT_IO.put(NET_FILE, "); 

P LAC E_S TACK . POP( PS , TEMP_POI NTER ) ; 

TEXT_IO.put(NET_FlLE, "p"); 

TEXT_IO.put(NET_FlLE, POS_TO_LIT( pos i t i ve ’ IMAGE ( TEMP_POINTER . 

SYMBOL. LOCATION))) ; 

while (not PLACESTACK . EMPTY ( PS ) ) loop 
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PLACE_STACK.POP(PS, TEMP_POINTER ) ; 

TEXT_IO. put( NET_F I LE , ", p"); 

TEXT_IO.put(NET_FILE, POS_TO_LIT( positive' I MAGE ( TEMP_POINTER . 

SYMBOL . LOCATION ) ) ) ; 

end loop; 

PLACE_STACK . DISPOSE ( PS) ; 

TEXT_IO.put(NET_FILE, " -> "); 

ABSTRACT_SYNTAX_LIST. RETRIEVE ( SYNTAX _LIST , TEMPPOINTER ) ; 

TEXT_IO . put(NET_FILE, "p"); 

TEXT_IO.put(NET_FILE, POS_TO_LIT( positive' IMAGE ( TEMP_POIN TER . 

SYMBOL . LOCATION ) ) ) ; 

while (not ABSTRACT_SYNTAX_LIST . LAST ( SYNTAX_LIST ) ) loop 
ABSTRACT_SYNTAX_LIST.FIND_NEXT(SYNTAX_LIST); 

ABSTRACT_SY N T AX_LI ST . RETRIEVE (SYNTAX_L I ST , T£MP_POINTER ) ; 

TEXT_lO,put( NET_FI LE , ", p"); 

TEXT_IO.put(NET_FILE , POS_TO_LIT(positi ve ’ IMAGE (TEMPPOINTER. 

SYMBOL . LOCATION ) ) ) ; 

end loop; 

TEXT_IO.new_l ine(NETFILE) ; 
end if; 
end XLATE ; 
begin 
begin 

TEX T_IO . create ( NET_FILE, TEXT_IO.out_f i le, "a. out", ""); 
exception 

when IO_EXCEPTIONS.USE_ERROR => 

TEXT_IO . open( NET_FILE , TEXT_IO . out_f i 1 e , "a. out", ""); 
when others => raise; 
end ; 

if (not FOREST_LIST . EMPTY ( FOREST ) ) then 
XLATE(START_SYNTAX); 

FOREST_LIST.FIND_FIRST( FOREST); 

FOREST_LI ST. RETRIEVE( FOREST, SYNTAXLIST) ; 

XLATE ( SYNTAX_LIST ) ; 

while (not FORESTLIST. LAST (FOREST) ) loop 
FOREST_LlST.FIND_NEXT( FOREST); 

FOREST_LIST . RETRIEVE ( FOREST , SYNTAX_L I ST ) ; 

XLATE(SYNTAX_LIST); 
end loop; 

ABSTRACT_SYNTAX_LIST.INSERT(STOP_PLACES, TRANSI TION_POINTER ) ; 
ABSTRACT_SYNTAX_LIST . INSERT ( STOPP LACES, CREATE_DUMMY_PLACE( "STOP” ) ) ; 
XLATE(STOP_PLACES); 

TEXT_IO.put(NET_FILE, "<p"); 

ABSTRACT_SYNTAX_LIST . F IND_F I RST( START_SYNTAX ) ; 

ABSTRACT SYNTAX LIST . RETRI EVE( START_SYNTAX , INITIAL_MARK) ; 
TEXT_IO.put(NET_FILE, POS_TO_L I T( pos i ti ve ' IMAGE( INITI AL_MARK . 

SYMBOL . LOCATION ) ) ) ; 

rEXT_IO.put(NET_FILE, ">"); 

TEXT_IO.close(NET_FILE ) ; 
end i f ; 
begin 
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TEXT_IO . create ( PLACE_FILE , TEXT_IO.out_f ile, "place.dat", ""); 
exception 

when IO_EXCEPTIONS . USE_ERROR => 

TEXT_IO. open( PLACE_FILE , TEXT_IO.out_f i le, "place.dat", 
when others => raise; 
end ; 

if (not C0DE_8L0CKER . IS_CODE_BLOCK_LIST_CLEAR) then 
CODE_BLOCKER.FIND_FIRST_CODE_BLOCK; 

TEXT_IO.put( PLACE_F I LE , "LOCATION"); 

TEXT_I0 . set_col ( PLACE_FILE , 20); 

TEXT_IO.put(PLACE_FILE , "CODE_BLOCK_LABEL" ) ; 

TEXT_I0 . set_col ( PLACE_FILE , 50); 

TEXT_I0.put( PLACE_FI LE , "STARTING LINE"); 

TEXT_IO. set_col ( PLACE_FILE , 65); 

TEXT_IO.put( PLACE_F ILE, "ENDING LINE"); 

TEXT_I0 . new_l ine( PLACE_F ILE , 2); 
loop 

TEXT_I0 . put( PLACE_FILE , "p"); 

TEXT_IO.put( PLACE_FILE , POS_TO_LI T ( pos i ti ve ’ IMAGE(CODE_BLOCKER . 

READ_CODE_BLOCK_NUMBER ) ) ) ; 

TEXT_I0. set_col ( PLACE_FILE , 20); 

TEXT_I0 . put( PLACEFILE , CODE_BLOCKER . READ_CODE_BLOCK_LABEL ) ; 
START_SOURCE_INFO := C0DE_BL0CKER . READ_CODE_BLOCK_$TART ; 
STOP_SOURCE_INFO := CODE_BLOCKER . READ_CODE_BLOCK_STOP ; 

TEXT_IO. set_col ( PLACE_FILE , 55); 

TEXT_IO.put( PLACE_FI LE , natural ’ IMAGE( START_SOURCE_INFO . LINE_NUMBER ) ) ; 
TEXT_I0 . set_Col ( PLACE_F ILE, 70); 

TEXT_I0 . put_l i ne( PLACE_FI LE , natural 1 IMAGE(STOP_SOURCE_INFO. 

LINE_NUM8ER) ) ; 

exit when CODE_BLOCKER . IS_LAST_CODE_8LOCK; 
CODE_BLOCKER.FIND_NEXT_CODE_BLOCK; 
end loop; 

TEXT_IO.close(PLACE_FILE); 

C0DE_BL0CKER.CLEAR_C0DE_8L0CKER; 

RESET_NET_GENERATOR ; 
end if; 

end TRANSLATE_TO_PEANUT ; 
begin 

INITIALIZE_NET_GENERATOR; 
end NET_GENERATOR ; 
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APPENDIX E 



"ADAFLOW” PROGRAM LISTING - SYMBOL TABLE 



TITLE: 


ADA FLOW 


-- 


MODULE NAME: 


PACKAGE SYMBOL_TABLE 


-- 


FILE NAME: 


SYM_T AB . ADS 


-- 


DATE CREATED: 


01 MAR 88 


__ 


LAST MODIFIED; 


28 APR 88 


-- 


AUTHOR(S): 


LT ALBERT J. GRECCO, USN 


- 


DESCRIPTION: 


This package contains the procedures which 
define the interface to the symbol table. 


- 



with TOKENSCANNER ; 



package SYMBOL_TABLE is 



type SYMBOL_TAG is (OBJECT_DECLARATION_TAG , TYPE_DECLARATION_TAG , 

FUNCTlON_DECLARATION_TAG , PROCEOURE_OECLARATION_TAG , 



PACKAGE_DECLARATION_TAG , 
ENTRY_TAG, 
PACKAGE_BODY_TAG , 
ACCEPT_TAG, 

SELECT_TAG , 



TASK_OECLARATION_TAG , 

TASK_BODY_TAG , 
LABELNAME, 

LOOP_TAG ) ; 



type SYM_TAB_RECDRD is 



record 

NAME 

NAME_LENGTH 

TAG_TYPE 

LOCATION 

REFERENCECOUNT 



st ri ng( 1 . . TOKEN_SCANNER .LINESIZE) : = (others => 
natural 0; 

SYMBOLTAG; 

natural := 0; -- 0 indicates undeclared, 
natural := 0; -- used to count the number of 






end record; 



-- pointers to this entry. DO NOT 
-- COLLECT GARBAGE UNLESS THIS IS 1. 



type SYM TAB_ACCESS is access SYMTABRECORD; 
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SYMBOL_TABLE_OVERFLOW : exception; 

DECLARATION_ERROR : exception; 

REFERENCE_ERROR : exception; 

procedure CLEAR_SYM_TAB ; 

-- post - SYM_TAB is returned to it's initialized state. 

function FULLSYMTAB return boolean; 

— post - If the size of SYM_TAB has not reached its bound then FULL is 
FALSE else FULL is TRUE. 

procedure EXITSCOPE; 

-- post - SYM_TAB backs up one static nesting level . The current entry is 
defined as the entry that caused the corresponding scope entry to 
occur. 

procedure I NSERT_SYM_TAB( KEY : in string; 

ATTRIBUTE : in SYMBOL_TAG ; 

LOCATION ; in natural); 

-- pre - SYM_TAB has not achieved its maximum allowable size. 

-- post - If the ATTRUBUTE is OBJECTDECLARATIONTAG , TYPE_CECLARATION_TAG , 
or LABEL_NAME , a search is conducted at the local SNL for a 
matching KEY. If no match is found, KEY is inserted with the given 
attribute and location and is the the current entry, else no 
action is taken and the current entry is the pre-existing entry 
named by key. 

If the ATTRIBUTE is FUNCTION_DECLARATION_TAG , 
PROCEDURE_DECLARATION_TAG , PACKAGE_DECLARATION_TAG , 
TASK_DECLARATION_TAG , or ENTRY_TAG, a search is conducted at the 
local SNL for a matching KEY. If no match is found, KEY is inserted 
with the given attribute and location and scope entry occurs, else 
a check is made to see if the pre-existing entry is a 
PROCEDURE_DECLARATION_TAG or a FUNCTION_DECLARATION_TAG . If so, 
location is updated and scope entry occurs. 

If the ATTRIBUTE is PACKAGE_BODY_TAG , TASK_BODY_TAG , or 
ACCEPT_TAG, the corresponding environment of definition is 
located, the location updated, and then scope entry occurs. 

If the ATTRIBUTE is L00P_TAG or SELECT_TAG, the symbol is entered 
with the given ATTRIBUTE and LOCATION and scope entry occurs. 

-- exceptions raised - SYMBOL_TABLE_OVERFLOW if the symbol table’s size 
has reached it's bound. 

DECLARATIONERROR if the required environment of 
definition can not be found for a body declaration 
or if a declaration tag already exists at the current 
SNL. 



function F INDKEY ( KEY : in string) return SYM_TAB_ACCESS; 

-- post - If the symbol table contains an entry whose key value is KEY, 
then that entry is the current entry and FINDKEY returns a 
pointer to that symbol table record, else FINDKEY returns 
a null pointer and the current entry is undefined. NOTE - 
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the symbol table IS case sensitive in it's comparison of keys and 
the search is global in scope according to ADA visibility rules. 

function F IND_L0CAL_KEY( KEY : in string) return SYM_TAB_ACCESS ; 

-- post - If the symbol table contains an entry whose key value is KEY, 
then that entry is the current entry and FIND_KEY returns a 
pointer to that symbol table record, else FIND_KEY returns 
a null pointer and the current entry is undefined. NOTE - 
the symbol table IS case sensitive in it's comparison of keys and 
the search is local in scope according to ADA visibility rules. 

function FIND_SUBPROGRAM_END return SYMTAB ^ACCESS ; 

-- post - A search is conducted to find the parent enclosing subprogram 
of the parse. A pointer to the label "END" for this parent 
enclosing subprogram is returned. This function is used to 
provide the operand for a "return" statement. The current entry 
is the corresponding end label for the enclosing subprogram of the 
parse. 

-- exceptions raised - RE FERENCE_ERROR if no enclosing subprogram can be 
found or if a label "END" can not be found for 
an enclosing subprogram. 

function F IND_L00P_END return SYM_TAB_ACCESS; 

— post - A search is conducted to find the enclosing loop 

of the parse. A pointer to the label "END" for this 
enclosing loop is returned. This function is used to 
provide the operand for an "exit" statement. The current entry 
is the end label corresponding to the enclosing loop of the 
parse. 

-- exceptions raised - REFERENCE_ERROR if no enclosing loop can be 

found or if a label "END" can not be found for 
an enclosing loop. 

function FIND_TASK_END return SYM_TAB_ACCESS ; 

-- post - A search is conducted to find the enclosing task 

of the parse. A pointer to the label "END" for this 
enclosing task is returned. The current entry 
is the end label corresponding to the enclosing task of the 
parse. 

-- exceptions raised - REFERENCE_ERROR if no enclosing task can be 

found or if a label "END" can not be found for 
an enclosing task. 



procedure UPDATE_SYM_TAB( LOCATION : in natural); 

-- pre - The current entry is defined. 

-- post - The current entry's location is changed to LOCATION. 



function 
-- pre 
-- post - 



SELECT_COMPONENT ( KEY : in string) return SYMTABACCESS ; 

The current entry is defined. 

SELECT_COMPONENT provides visibility to the next static nesting 
level below the current entry. If the symbol table contains an 
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function 
-- post - 

procedure 
-- pre 
-- post - 

procedure 
-- pre 
-- post - 

procedure 
-- post - 



end SYMBOL 



entry whose key value is KEY at the next static nesting level, 
then that entry is the current entry and FIND_KEY returns a 
pointer to that symbol table record, else FIND_KEY returns 
a null pointer and the current entry is undefined. NOTE - 
the symbol table IS case sensitive in it's comparison of keys. 

RETRIEVE_SYM return SYM_TAB_ACCESS; 

RETRIEVE_SYM returns a pointer to the current entry or null if 
the current entry is undefined. 

SAVE _CURRENT_ENTRY ; 

The current entry is defined; 

The current entry is saved in a last in first out data structure. 

RESTORE_CURRENT_ENTRY ; 

A current entry was saved; 

The last current entry saved is the current entry. 
PRINT_SYMBOL_TABLE; 

Useful as a debugging tool, PRINT_SYMBOL_TABLE prints a dump of 
every symbol table entry, including attribute and location 
information, to the standard output device. 

TABLE; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE SYMBOL_TABLE 

-- FILE NAME: SYM_TAB . ADB 



-- DATE CREATED: 01 MAR 88 

-- LAST MODIFIED: 28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



-- DESCRIPTION: This package contains the procedures which 

implement the interface to the symbol table. 



with TOKEN_SCANNER , 

GENERIC_STACK, 

UNCHECKED_DEAL LOCATION , 

TEX T 10 ; 

package body SYMBOL_TABLE is 

procedure FREE_SYM_REC is new 

UNCHECKED_DEALLOCATION(SYM_TAB_RECORD,SYM_TAB_ACCESS) ; 
subtype DEFINITIONTAGS is SYMBOL_TAG range 

FUNCTION_DECLARATION_TAG . . ENTRY_TAG ; 
subtype B0DY_TAGS is SYMBOL_TAG range PACKAGE_BODY_TAG . . ACCEPT_TAG ; 

type LIST_NODE ; 

type LIST_NODE_POINTER is access LIST_N0DE ; 
package SYMBOL_LIST is 

type LISTINSTANCE is private; 

type LIST is access LIST_INSTANCE ; 

LIST_OVERFLOW : exception; 

LISTJJNDERFLOW : exception; 

-- Operations: If the list is not empty, then one of the nodes is designated 

as the current node. Ocaasional ly , in the postcondition, it is necessary 
to refer to the list of the current node as they were immediately before 
execution of the operation. L-pre and c-pre, respectively, are employed 
for these references. 

procedure FIND_FIRST ( L : in out LIST); 

- pre - The list L is not empty. 
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-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure FIND_NEXT(L : in out LIST); 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERF10W if L is empty. 

- LISTOVERFLOW if the last node is the current node. 

procedure FIND_PREVIOUS(L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LI ST_UNDERFLOW if L is empty or c is the first node. 

procedure FIND_LAST ( L : in out LIST); 

— pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure RETRIEVE^ ; in LIST; ITEM ; out LIST_NODE_POINTER ) ; 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

— exceptions raised - LISTUNDERFLOW if L is empty. 

procedure UPDATE( L : in out LIST; ITEM : in LIST_NODE_POINTER) ; 

-- pre - The list L is not empty. 

— post - The current node in L contains ITEM as its element. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

procedure INSERT ( L : in out LIST; ITEM : in LIST_NODE_POINTER ) ; 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 

node in L-pre, if any, is its predecessor. The node containing 

ITEM is the current node. 

-- exceptions raised - LISTOVERFLOW if L has reached its bound. 

procedure DELETE( L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

function SIZE_0F(L : in LIST) return natural; 

-- post - SIZE_0F is the number of nodes in list L. 

function EMPTY ( L : in LIST) return boolean; 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 
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function FULL(L : in LIST) return boolean; 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 

function FIRST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
procedure CREATE(L : in out LIST; SUCCESS : out boolean); 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

procedure DISP0SE(L ; in out LIST); 

-- post - L-pre does not exist. 

procedure ASSIGN(L1 : in LIST; L2 : in out LIST); 

-- post - L2 contains the same nodes as LI. 

procedure SAVE_LIST(L ; in LIST); 

-- post - L is saved in a last in first out data structure. 

procedure RESTORE_LIST ( L : in out LIST); 

-- post - L is the last list that was saved. 

private 

type NODE; 

type NODEPOINTER is access NODE; 
type NODE is 
record 

ELEMENT : LIST_N0DE_P0INTER ; 

NEXT : N0DE_P0INTER; 
end record; 
type LIST_INSTANCE is 
record 

HEAD : N0DE_P0INTER := null; 

TAIL : NODE_POINTER := null ; 

CURRENT : NODE POINTER := null; 

SIZE : natural := 0; 
end record; 

end SYMBOL LI ST ; 
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type LISTJJODE is 
record 

SYMBOL : SYM_TAB_ACCESS ; 

SUB_LI ST : SYMBOL_LIST .LIST; 

end record; 



SYM_TAB 

CURRENT_SNL 

SEARCH_SNL 



SYMBOL_LI ST .LIST; -- the root of the symbol table tree 
SYMBOL_LIST . LIST ; -- keeps track of the current branch 
SYMBOL_LIST . LIST; -- can be operated on without effecting 
-- the state of the symbol table. 



LAST_FOUND : LI ST_N0DE_P0 INTER := null; 

package STK_OF_LISTS is new GENERIC_STACK( SYMBOL_LIST . LIST) ; 

SCOPE_STACK : STK_OF_LISTS. STACK; 
package body SYMBOL_LIST is 

procedure FREE_N00E is new UNCHECKED_DEALLOCATIQN( NODE , NODE_POINTER ) ; 
procedure FREE_LIST is new UNCHECK ED_0EALL0CATI ON ( LI ST_INSTANCE , LIST); 
procedure FREE_SYM_REC is new 

UNCHECKED_DEALLOCATION( SYM_TAB_RECORD ,SYM_TAB_ACCESS ) ; 
package STACK_LIST_INSTANCES is new GENERIC_STACK( LIST) ; 

SLI : STACK_LIST_INSTANCES. STACK; 

SUCCESS : boolean; 

procedure FIND_FIRST(L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if (EMPTY(L)) then 
raise LISTJJNDERFLOW; 
end if; 

L. CURRENT := L . HEAD ; 
end FIND_FIRST; 

procedure FIND_NEXT(L : in out LIST) is 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

- LIST_OVERFLOW if the last node is the current node. 

begin 

if (EMPTY(L)) then 
raise LISTJJNDERFLOW; 
end if; 

if ( LAST ( L ) ) then 
raise LISTOVERFLOW; 
end if; 
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L. CURRENT := L .CURRENT. NEXT; 
end FIND_NEXT ; 



procedure FIN0_PREVI0US( L : in out LIST) is 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UN0ERFL0W if L is empty or c is the first node. 

TEMP_POINTER : NODE_POINTER ; 

begin 

if ( EMPTY ( L ) or FIRST ( L ) ) then 
raise LISTJJNDERFLOW; 
end if; 

TEMP_POINTER := L.HEAO; 

while ( TEMP_POINTER .NEXT /= L. CURRENT) loop 
TEMP_POINTER := TEMP_POINTER . NEXT ; 
end loop; 

L. CURRENT := TEMPPOIN TER ; 
end FI ND_PREVIOUS ; 

procedure FIND_LAST(L : in out LIST) is 
-- pre - The list L is not empty. 

- post - The last node in L is the current node. 

-- exceptions raised - LISTJJNDERFLOW if L is empty, 
begin 

if ( EMPTY ( L) ) then 
raise LISTJJNOERFLOW; 
end if; 

while (not LAST(L)) loop 
FIND_NEXT( L) ; 
end loop; 
end FIND_LAST; 



procedure RETRIEVE( L : in LIST; ITEM : out LIST_NODE_POINTER ) is 
-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

begin 

if ( EMPTY ( L ) ) then 
raise LISTJJNOERFLOW; 
end if; 

ITEM := L. CURRENT. ELEMENT; 
end RETRIEVE; 



procedure UPDATE( L : in out LIST; ITEM : in LIST JIODE_POINTER ) is 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if (EMPTY(L)) then 
raise LISTJJNDERFLOW; 
end if; 
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L. CURRENT. ELEMENT := ITEM; 
end UPDATE; 



procedure INSERT ( L : in out LIST; ITEM : in LIST_NODE_POlNTER ) is 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 

node in L-pre, if any, is its predecessor. The node containing 

ITEM is the current node. 

-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 

TEMP_POINTER : N0DE_P0INTER; 

begin 

if (FULL(L)) then 
raise LIST_OVERFLOW ; 
end if; 

TEMPPOINTER := new NODE' (ITEM, null); 

TEMPPOI NTER. ELEMENT. SYMBOL. REFERENCE_COUNT ;= 

natural ’ SUCC( TEMP_POINTER . ELEMENT . SYMBOL . REFERENCECOUNT ) ; 
if { L . HEAD = null) then 
L .HEAD := TEMP_P0INTER ; 

L . TAIL := TEMP_POINTER ; 
else 

L. TAIL. NEXT ;= TEMP_POI NTER ; 

L . TAIL := TEMP_POINTER; 

end if; 

L. CURRENT := TEMPPOINTER; 

L.SIZE := L.SIZE + 1; 
end INSERT; 



procedure DELETE(L ; in out LIST) is 
-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

TEMP_POI NTER ; NODE_POINTER; 
begin 

if ( EMPTY ( L ) ) then 
raise LIST_UNDERFLOW ; 
end if; 

if (L. CURRENT /= L .HEAD) then 
TEMP_P0INTER := L .HEAD ; 

while ( TEMP_POINTER .NEXT /= L. CURRENT) loop 
TEMP_P0I NTER ;= TEMPPOINTER . NEXT ; 
end loop; 

TEMP_POINTER .NEXT ;= L . CURRENT . NEX T ; 
if (L. CURRENT = L . TAIL) then 
L . TAIL := TEMPPOINTER; 
end if; 
e 1 se 

if ( L . HEAD = L . TAIL ) then 
L. TAIL := null; 
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end if; 

L . HEAD := L . HEAD . NEXT ; 
end if; 

if (L. CURRENT. ELEMENT. SYMBOL. REFERENCECOUNT > 1) then 
L. CURRENT. ELEMENT. SYMBOL. REFERENCE_COUNT 

pos i t i ve ' PRED( L . CURRENT . ELEMENT . SYMBOL . REFERENCE_COUNT ) ; 

else 

FREE_SYM_REC( L . CURRENT . ELEMENT . SYMBOL ) ; 
end i f ; 

DISPOSER. CURRENT. ELEMENT. SUB_LIST); 

FREE_NODE(L. CURRENT); 

L. CURRENT := L . TAIL; 

L.SIZE := L.SIZE - 1; 
end DELETE; 

function SIZE_OF(L : in LIST) return natural is 
-- post - SIZE_OF is the number of nodes in list L. 
beg i n 

return (L.SIZE); 
end SIZE_OF ; 

function EMPTY(L : in LIST) return boolean is 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 

begin 

return (L.HEAD = null); 
end EMPTY; 

function FULL(L : in LIST) return boolean is 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 

TEMPPOINTER : NODE_POINTER; 
begin 

TEMP_POINTER := new NOOE; 

FREE_NODE( TEMP_POINTER) ; 
return (FALSE); 
exception 

when STORAGE_ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 

function FIRST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

-- exceptions raised LISTUNDERFLOW if L is empty, 
begin 

if (EMPTY(L)) then 

raise LIST UNDERFI OW; 
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end if; 

return (L. CURRENT = L .HEAD) ; 
end FIRST; 

function LAST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if ( EMPTY ( L ) ) then 
raise LIST_UNDERFLOW ; 
end if; 

return (L. CURRENT = L . TAIL ) ; 
end LAST; 

procedure CREATE( L : in out LIST; SUCCESS : out boolean) is 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

begin 

L := new LIST_INSTANCE ’(null, null, null, 0); 

SUCCESS := TRUE; 
exception 

when ST0RAGE_ERR0R => 

SUCCESS := FALSE; 
when others => 
raise; 
end CREATE; 

procedure DISP0SE(L : in out LIST) is 
-- post - L-pre does not exist, 
begin 

if (not EMPTY ( L ) ) then 
FINDLAST(L); 
while (not EMPTY(L) ) loop 
DELETE(L); 
end loop; 
end if; 

FREE_LIST(L); 
end DISPOSE; 



procedure ASSIGN(L1 : in LIST; L 2 : in out LIST) 
-- post - L2 contains the same nodes as LI. 



begin 
L2 . HEAD 
L2. CURRENT 
L2 . TAIL 
L2.SIZE 
end ASSIGN; 



LI. HEAD; 

LI .CURRENT; 
LI .TAIL; 

Li. SIZE; 



is 
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procedure SAVE_LIST(L : in LIST) is 

-- post - L is saved in a last in first out data structure. 
TEMP_LIST : LIST; 

SUCCESS : boolean; 
begin 

CREATE ( TEMP_LI ST , SUCCESS); 
if {not SUCCESS) then 

raise SYMB0L_TA8LE_0VERFL0W ; 
end if; 

ASSIGN(L, TEMP_LIST) ; 

STACK_LIST_INSTANCES . PUSH{ SLI , TEMP_LIST) ; 
end SAVE_LIST ; 

procedure RESTORE_LIST ( L : in out LIST) is 
-- post - L is the last list that was saved. 

TEMP_LIST : LIST; 
begin 

STACK_LI ST_INSTANCES . POP ( SLI , TEMPLIST) ; 

ASSIGN( TEMP_LIST , L); 

FREE_LIST(TEMP_LIST); 
end RESTORE_LIST ; 



begin 

STAC K_L I ST_INSTANCES .CREATE ( SLI , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

end SYMBOL_LIST; 



function SNL_SEARCH( KEY : in string) return LIST_NODE_POINTER is 
-- post - If the symbol table contains an entry at the local scope whose 
key value is KEY, then that entry is the current entry in the 
list SEARCHSNL and SNL_SEARCH returns a pointer to that list 
node, else SNL_SEARCH returns a null pointer and the 
current entry in the list SEARCHSNL is the last entry. 
SEARCH_POINTER : LIST_N00E_P0INTER ; 
beg i n 

if ( SYMB0L_LI ST . EMPTY ( SEARCH_SNL ) ) then 
return (null); 



else 

SYMBOL_LIST . F IND_FI RST ( SEARCH_SNL ) ; 

1 oop 

SYMBOLLIST . RETRIEVE ( SEARCH_SNL , SEARCH_POI NTER ) ; 
if ( (SEARCH_POINTER. SYMBOL. NAME_LENGTH = KEY ' LENGTH ) and then 
(SEARCH_POINTER. SYMBOL. NAME( 1 . .KEY' LAST) = KEY)) then 
return (SEARCHPOINTER) ; 



else 

exit when (SYMB0L_L I ST . LAST ( SEARCH_SNL ) ) ; 
SYMBOLLIST . F IND_NEXT( SEARCH_SNL ) ; 
end if; 



end loop; 
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return (null); 
end if; 

end SNL_SEARCH ; 

procedure INITIALIZE_SYM_TAB is 

-- post - SYM_TAB contains the names and defined attributes for the language 
defined enclosing scopes. 

SUCCESS : boolean; 
begin 

SYMBOL_LIST .CREATE( SYMTAB , SUCCESS ) ; 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

SYMBOL_LIST . CREATE ( SEARCH_SNL , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 

STK_OF_LISTS.CREATE(SCOPE_STACK, SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

CURR£NT_SNL := SYM_TAB; 
end INITIALIZE_SYM_TAB; 



procedure CL£AR_SYM_TAB is 

-- post - SYM_TAB is returned to it’s initialized state. 

SUCCESS : boolean; 

begin 

SYMBOL_LIST.DISPOSE(SYM_TAB); 

STK_OF_LI$TS . DISPOSE ( SCOPE_STACK ) ; 

SYMBOL_LIST . CREATE ( SYM_TAB , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OV£RFLOW ; 
end if; 

STK_OF_LISTS .CREATE( SCO PE_S TACK , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 

CURRENT_SNL := SYM_TAB; 

LAST_FOUND := null ; 
end CLEAR_SYM_TAB ; 



function FULLSYMTAB return boolean is 

-- post - If the size of SYMTAB has not reached its bound then FULL is 
FALSE else FULL is TRUE. 

begin 

return ( SYMBOL_LIST . FULL(CURRENT_SNL ) ) ; 
end FULLSYMTAB; 

procedure ENTERSCOPE is 

-- post - SYMTAB enters the next static nesting level. 
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TEMP_P0INTER : LIST_N0DE_P0INTER ; 
begin 

STK_OF_LIST S . PUSH( SCOPE_STACK , CURRENT_SNL ) ; 

SYM80L_LIST . RETRI EVE ( SEARCH_SNL , TEMP_POINTER) ; 

CURRENT_SNL := TEMP_POINTER . SUB_LIST ; 

SYMBOL_LIST .ASSIGN(CURRENT_SNL, SEARCH_SNL ) ; 
end ENTER_SCOPE; 

procedure ENTER_SEARCH_SCOPE is 

-- post - SYM_TAB enters the next static nesting level. 

TEMPPOINTER : LIST_NODE_POINTER; 
begin 

SYM80L_L 1ST . RETRI EVE ( SEARCH_SNL , TEMP_P0INTER) ; 

SYM80L_LIST . ASSIGN( TEMP_POINTER . SUB_LIST , SEARCH_SNL ) ; 
end ENTER_SEARCH_SCOPE; 

procedure EXIT_SCOPE is 

-- post - SYMTAB backs up one static nesting level. The current entry is 
defined as the entry that caused the corresponding scope entry to 
occur. 

TEMPPOINTER : LIST_NODE_POINTER ; 
begin 

STK_OF_LISTS . POP( SCOPE_STACK , CURRENT_SNL ) ; 

SYM80L_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL ) ; 

SYMBOL_LIST . RETRI EVE ( SEARCH_SNL , LAST_FOUND); 
end EXIT_SCOPE ; 

procedure INSERT_SYM_TAB( KEY : in string; 

ATTRIBUTE : in SYMBOL_TAG ; 

LOCATION : in natural) is 

-- pre - SYM_TAB has not achieved its maximum allowable size. 

-- post - If the ATTRU8UTE is OBJECT_DECLARATION_TAG , TYPE_CECLARATION_TAG , 
or LABEL_NAME , a search is conducted at the local SNL for a 
matching KEY. If no match is found, KEY is inserted with the given 
attribute and location and is the the current entry, else no 
action is taken and the current entry is the pre-existing entry 
named by key. 

If the ATTRIBUTE is FUNCTION_DECLARATION_TAG , 
PROCEDURE_DECLARATION_TAG , PACKAGE_DECLARATION_TAG , 
TASKDECLARATIONTAG, or ENTRY_TAG , a search is conducted at the 
local SNL for a matching KEY. If no match is found, KEY is inserted 
with the given attribute and location and scope entry occurs, else 
a check is made to see if the pre-existing entry is a 
PROCEDURE_DECLARATION_TAG or a FUNCTION_DECLARATION_TAG . If so, 
location is updated and scope entry occurs. 

If the ATTRIBUTE is PACKAGE_BODY_TAG , TASK_BODY_TAG , or 
ACCEPTTAG, the corresponding environment of definition is 
located, the location updated, and then scope entry occurs. 

If the ATTRIBUTE is LOOPTAG or SELECTTAG, the symbol is entered 
with the given ATTRIBUTE and LOCATION and scope entry occurs, 
exceptions raised - SYMBOLTABLEOVERFLOW if the symbol table's size 
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has reached it's bound. 

DECLARATIONERROR if the required environment of 
definition can not be found for a body declaration 
or if a declaration tag already exists at the current 
SNL . 

TEMP_POINTER : LIST_NODE_POINTER; 

SEARCHPOINTER : LIST_NODE_POINTER; 

TEMPSYMBOL : SYM_TAB_ACCESS ; 

SUCCESS : boolean; 
use SYMBOL_LIST; 
begin 

if ((ATTRIBUTE = OB JECT_DECLARATION_TAG ) or else 

(ATTRIBUTE = TYPE_DECLARATION_TAG ) or else (ATTRIBUTE = LABELJJAME)) then 
SYMBOL_LIST .ASSIGN ( CURRENT_SNL , SEARCH_SNL) ; 

SEARCH_POINTER := SNL_SEARCH( KEY ) ; 
if (SEARCHPOINTER = null) then 

if (not SYMBOL_LIST . FULL( CURRENT_SNL ) ) then 
TEMP_POINTER := new LIST_NODE ; 

TEMP_POINTER. SYMBOL := new SYM_TAB_RECORD ; 

TEMP_POINTER. SYMBOL . NAME_LENGTH := KEY ’ LENGTH ; 

TEMPPOINTER. SYMBOL. NAME := (others => ' '); 

TEMP_P0INTER . SYMBOL . NAME( 1 . . KEY ’ LAST ) := KEY; 

TEMP_POINTER. SYMBOL. TAG_TYPE := ATTRIBUTE; 

TEMP_POINTER. SYMBOL. LOCATION := LOCATION; 

TEMP_POINTER. SYMBOL. REFERENCE_COUNT := 0; 

SYMB0L_LIST . CREATE ( TEMP_POINTER . SUB_LIST , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 

SYMB0L_LIST . I NSERT( CURRENT_SNL , TEMP POINTER) ; 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL) ; 

LAST_FOUND := TEMP_POINTER ; 
else 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 
else 

SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL) ; 

LAST_FOUND := SEARCH_POINTER ; 
end if; 

elsif (ATTRIBUTE in DEFINITION _TAGS) then 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL ) ; 

SEARCH_POINTER := SNL_SEARCH( KEY ) ; 
if (SEARCH_POINTER = null) then 

if (not SYMBOL_LIST . FULL( CURRENT_SNL ) ) then 
TEMP_POINTER := new LIST_N0DE ; 

TEMP_POINTER. SYMBOL := new SYM_TAB_RECORD ; 

TEMP_POINTER. SYMBOL. NAMELENGTH := KEY ' LENGTH ; 

TEMP_POINTER. SYMBOL. NAME : = (others => ’ ’); 

TEMP_POINTER. SYMBOL. NAME( 1 . .KEY’LAST) ;= KEY; 

TEMPPOINTER. SYMBOL. TAG_TYPE := ATTRIBUTE; 

TEMPPOINTER. SYMBOL. LOCATION : = LOCATION; 
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TEMP_POI NTER . SYMBOL . RE FERENC E_COUNT := 0; 

SYMBOL_LIST . CREATE ( TEMP_POINTER . SUB_LIST , SUCCESS) ; 
if (not SUCCESS) then 

raise SYMBOLTABLEOVERFLOW; 
end if; 

SYMBOLLIST . INSERT(CURRENT_SNL , TEMP_POI NTER ) ; 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL) ; 

LAST_FOUND ;= TEMP_POINTER ; 

ENTER_SCOPE ; 
else 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

el si f ((ATTRIBUTE = FUNCTION_DECLARATION_TAG ) or 

(ATTRIBUTE = PROCEDURE J1ECLARAT ION_TAG ) ) then 
UPDATE_SYM_TAB( LOCATION) ; 

SYMB0L_LIST . ASSIGN( SEARCH_SNL , CURRENT_SNL ) ; 

LAST_FOUND ;= SEARCH_POI NTER ; 

ENTER_SCOPE ; 
else 

raise DECLARATION_ERROR ; 
end if; 

elsif (ATTRIBUTE in BODY_TAGS) then 

SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL ) ; 

TEMP_SYMBOL : = F IND_KEY( KEY ) ; 
if (TEMP_SYMBOL = null) then 
LAST_FOUND := null; 
raise DECLARATION_ERROR ; 
else 

UPDATE_SYM_TAB( LOCATION) ; 
if (SEARCH_SNL = CURRENT_SNL) then 

SYMBOL_LIST . ASSIGN ( SEARCH_SNL , CURRENT_SNL ) ; 
end if; 

SYMBOL_LIST . RETRIEVE ( SEARCH_SNL , LAST_FOUND) ; 

ENTER_SCOPE ; 
end if; 

elsif ((ATTRIBUTE = LOOP_TAG) or else (ATTRIBUTE = SELECT_TAG ) ) then 
if (not SYMBOL_LIST . FULL( CURRENT_SNL ) ) then 
TEMP_POINTER := new LIST_NODE ; 

TEMP_POINTER. SYMBOL := new SYM_TAB_RECORD ; 

TEMP_POINTER . SYMBOL . NAME_LENGTH := KEY ' LENGTH ; 

TEMP_POINTER. SYMBOL. NAME := (others => ' ’); 

TEMP_POINTER. SYMBOL. NAME( 1. .KEY’LAST) := KEY; 

TEMP_POINTER. SYMBOL. TAG_TYPE := ATTRIBUTE; 

TEMP_POINTER. SYMBOL. LOCATION : = LOCATION; 

TEMP_POINTER. SYMBOL. REFERENCE_COUNT := 0; 

SYMBOLLIST . CREATE ( TEMPPO I NTER . SUB_LIST , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE ^OVERFLOW; 
end if; 

SYMBOL_L 1ST . INSERT (CURRENTSNL , TEMPPOINTER) ; 

SYMBOLLIST . ASSIGN( CURRENTSNL , SEARCHSNL ) ; 
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LAST_FOUND := TEMP_POINTER ; 

ENTER_SCOPE ; 
else 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 
end if; 
exception 

when STORAGE_ERROR => 

raise SYMBOL_TABLE_OVERFLOW ; 
when others => 
raise; 

end INSERT_SYM_TAB ; 



function FIN0_KEY ( KEY : in string) return SYM_TAB ^ACCESS is 
-- post - If the symbol table contains an entry whose key value is KEY, 
then that entry is the current entry and FIND_KEY returns a 
pointer to that symbol table record, else FIND_KEY returns 
a null pointer and the current entry is undefined. NOTE - 
the symbol table IS case sensitive in it's comparison of keys and 
the search is global in scope according to ADA visibility rules. 
TEMP_POINTER : LIST_NODE_POINTER; 

TEMP_LI ST : SYMBOLLIST . LIST ; 

SEARCH_STACK : STK_0F_LISTS. STACK; 

SUCCESS : boolean; 
begin 

STK_OF_LISTS .CREATE ( SEARCH_STACK , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 

SYMB0L_LIST . ASSIGN ( CURRENT_SNL , SEARCH_SNL ) ; 

TEMP_POINTER := SNL_SEARCH( KEY ) ; 
if (TEMPPOINTER /= null) then 
LAST_FOUND := TEMPPOINTER; 
return ( TEMP_POINTER . SYMBOL ) ; 
else 

while (not STK_0F_LI STS . EMPTY ( SCOPE_STACK) ) loop 
STK_OF_LISTS.POP(SCOPE_STACK, TEMPLIST); 

STK_OF_LISTS. PUSH( SEARCHSTACK , TEMP_LIST ) ; 

SYMBOL_LIST . ASSIGN ( TEMP_LI ST , SEARCH_SNL ) ; 

TEMP_P0I NTER := SNL_SEARCH( KEY ) ; 
if ( TEMP_POINTER /= null) then 
while (not STK_0F_LISTS. EMPTY (SEARCH_ST AC K) ) loop 
STK_0F_LI ST S . P0P( SEARCH_STACK , TEMP_LIST ) ; 

STK_OF_LISTS . PUSH ( SCOPE _ST AC K , TEMP_LIST ) ; 
end loop; 

LAST_FOUND := TEMP_POINTER; 
return ( TEMP_POINTER . SYMBOL ) ; 
end if; 
end loop; 

while (not STK_OF LISTS . EMPTY( SEARCHSTACK ) ) loop 
STK_OF_LISTS . POP( S E ARC H_S TACK , TEMPLIST); 
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STK_OF _LI STS . PUSH( SCOPE_STACK , TEMP_LI ST ) ; 
end loop; 

LAST_FOUND := null; 
return (null); 
end if; 
end FIND_KEY; 

function FI ND_LOCAL _KEY( KEY : in string) return SYM_TAB_ACCESS is 
-- post - If the symbol table contains an entry whose key value is KEY, 
then that entry is the current entry and FIND_KEY returns a 
pointer to that symbol table record, else FINDKEY returns 
a null pointer and the current entry is undefined. NOTE - 
the symbol table IS case sensitive in it's comparison of keys and 
the search is local in scope according to ADA visibility rules. 
TEMPPOINTER : LIST_NODE_POINTER; 
begin 

SYMBOL_LIST .ASSIGN ( CURRE NT_SNL , SEARCH_SNL); 

TEMP_POI NTER := SNL_SE ARCH ( KEY ) ; 
if (TEMP_POINTER /= null) then 

SYMBOL_LIST.ASSIGN(SEARCH_SNL, CURRENT_SNL ) ; 

LAST_FOUND := TEMPPOINTER ; 
return (TEMP_POINTER, SYMBOL); 
else 

LAST_FOUND := null; 
return (null); 
end if; 

end FIND_LOCAL_KEY; 

function FI ND_SUBPROGRAM_END return SYMTABACCESS is 
-- post - A search is conducted to find the parent enclosing subprogram 
of the parse. A pointer to the label "END" for this parent 
enclosing subprogram is returned. This function is used to 
provide the operand for a "return" statement. The current entry 
is the end label corresponding to the enclosing subprogram of the 
parse. 

-- exceptions raised - REFERENCEERROR if no enclosing subprogram can be 
found or if a label "END" can not be found for 
an enclosing subprogram. 

PARENT : LIST_NODE_POINTER; 

TEMP LIST : SYMBOL_LI ST . LI ST ; 

SEARCHSTACK : STK OF L I STS . STACK ; 

SUCCESS : boolean; 
beg i n 

STKOFLI STS . CREATE ( SEARCHSTACK , SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

SYMBOL _L 1ST. ASSIGN( CURRENTSNL , SEARCHSNL); 
if (not STK_OF_L I STS . EMPTY ( SCOPESTACK ) ) then 
STK OF LISTS. POP( SCOPESTACK , TEMPLIST) ; 

STK OF LI STS. PUSH( SEARCH STACK, TEMPLIST); 
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SYMBOL_LIST . ASSIGN ( TEMP_LIST , SEARCH_SNL ) ; 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, PARENT); 

while (( PARENT. SYMBOL. TAG_TYPE /= FUNCTlON_DECLARATION_TAG ) and then 
(PARENT. SYMBOL. TAG_TYPE /= PROCEDURE_DECLARAT ION_TAG ) ) loop 
if ( STK_OF_LISTS . EMPTY ( SCOPE_STACK ) ) then 
raise REFERENCE_ERROR ; 
end if; 

STK_OF_LISTS . POP( SCOPE_STACK , TEMP_LIST ) ; 

STK_OF_LISTS . PUSH( SEARCH_STACK , TEMP_LIST ) ; 
SYMBOL_LIST.ASSIGN(TEMP_LIST, SEARCH_SNL ) ; 

SYMBOL_LIST .RETRIEVE(SEARCH_SNL, PARENT) ; 
end loop; 

while (not STK_OF_LISTS. EMPTY( SEARCH_STACK ) ) loop 
STK_OF_LISTS . POP ( SEARCH_STACK , TEMP_LIST ) ; 

STK_OF_LISTS . PUSH( SCOPE_STACK , TEMP_LIST ) ; 
end loop; 

SYMBOL_LIST . ASSIGN ( PARENT . SUB_L I ST , SEARCH_SNL) ; 

PARENT := SNL_SEARCH( "END" ) ; 
if (PARENT /= null ) then 
LAST_FOUND := PARENT; 
return ( PARENT . SYMBOL ) ; 
else 

raise REFERENCEERROR ; 
end if; 
else 

raise REFERENCE_ERROR ; 
end if; 

end F I ND_SUBPROGRAM_END ; 

function FIND_LOOP_END return SYM_TAB_ACCESS is 

-- post - A search is conducted to find the enclosing loop 

of the parse. A pointer to the label "END" for this 
enclosing loop is returned. This function is used to 
provide the operand for an "exit" statement. The current entry 
is the end label corresponding to the enclosing loop of the 
parse. 

-- exceptions raised - REFERENCEERROR if no enclosing loop can be 

found or if a label "END" can not be found for 
an enclosing loop. 

PARENT : LlST_NODE_POINTER ; 

TEMP_LIST : SYMBOL_LIST.LIST; 

SEARCH_STACK : STK_OF_LISTS . STACK ; 

SUCCESS : boolean; 
begin 

STK_OF_LISTS ,CREATE( SEARCHSTACK , SUCCESS) ; 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW ; 
end if; 

SYMBOL_LIST . ASSIGN ( CURRENT_SNL , SEARCH_SNL ) ; 
if (not STKOFLISTS . EMPTY ( SCOPE STACK) ) then 
STK_OF_LISTS.POP( SCOPE STACK , TEMPLIST) ; 
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S T K 0 F L I S T S . PUSH( SEARCH_STACK , TEMP_LIST ) ; 

SYMBOL_LIST.ASSIGN(TEMP_LIST. SEARCH_SNL ) ; 

SYMBOL_LIST . RETRIEVE ( SEARCH_SNL , PARENT); 
while (PARENT. SYMBOL. TAG_TYPE /= LOOP_TAG) loop 
if (STK_OF_LISTS.EMPTY(SCOPE_STACK)) then 
raise REFERENCE_ERROR; 
end if; 

STK_OF_LISTS . POP( SCOPESTACK , TEMP_LIST ) ; 

STK_OF_LISTS . PUSH( SEARCH_ST ACK , TEMP_LIST) ; 

SYMBOL_LIST . ASSIGN( TEMP_LIST , SEARCH_SNL) ; 

SYMBOL_LIST .RETRIEVE( SEARCH_SNL , PARENT) ; 
end loop; 

while (not STK_OF_LISTS. EMPTY( SEARCH_STACK ) ) loop 
STK_OF_LISTS.POP(SEARCH_STACK, TEMP_LIST ) ; 

STK_OF_LI STS . PUSH( SCOPE_STACK , TEMPJ.IST); 
end loop; 

SYMBOL_LIST . ASSIGN ( PARENT . SUB_LIST, SEARCH_SNL ) ; 

PARENT := SNL_SEARCH( "END" ) ; 
if (PARENT /= null) then 
LAST_FOUND := PARENT; 
return ( PARENT . SYMBOL ) ; 
else 

raise REFERENCE_ERROR; 
end if; 
else 

raise REFERENCE_ERROR ; 
end if; 

end FIND_LOOP_END ; 

function FIND_TASK_END return SYM_TAB_ACCESS is 

-- post - A search is conducted to find the enclosing task 

of the parse. A pointer to the label "END" for this 
enclosing task is returned. The current entry 
is the end label corresponding to the enclosing task of the 
parse. 

-- exceptions raised - REFERENCE_ERROR if no enclosing task can be 

found or if a label "END" can not be found for 
an enclosing task. 

PARENT : LISTNODEPOINTER; 

TEMP_LIST : SYMBOL_LIST .LIST; 

SEARCH_STACK : STK_OF_LISTS . STACK ; 

SUCCESS : boolean; 
begin 

STK_OF_L I STS. CREATE (SEARCH_STACK, SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE ^OVERFLOW; 
end if; 

SYMBOL_LIST .ASSIGN(CURRENT_SNL, SEARCH_SNL ) ; 
if (not STK_OF_LI STS . EMPTY ( SCOPE_STACK ) ) then 
STKOFLI STS . POP ( SCOPE ST ACK , TEMPLIST); 

STK OF LISTS. PUSH( SEARCHSTACK , TEMP_LIST ) ; 
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SYMBOL_LIST . ASSIGN ( TEMP_LI ST , SEARCH_SNL) ; 

SYMBOL_LIST . RETRIEVE( SEARCH_SNL , PARENT ) ; 
while (PARENT. SYMBOL. TA6_TYPE /= TASK_DECLARATION_TAG ) loop 
if (STK_OF_LISTS.EMPTY(SCOPE_STACK)) then 
raise REFERENCE_ERROR ; 
end if; 

STK_OF_LISTS . P0P( SCOPE_STACK , TEMP_LIST ) ; 
STK_OF_LISTS.PUSH(SEARCH_STACK, TEMP_LIST ) ; 

SYMB0L_LIST . ASSIGN( TEMP_LIST , SEARCH_SNL ) ; 

SYMBOL_LIST . RETRIEVE(SEARCH_SNL , PARENT); 
end loop; 

while (not STK_OF_LISTS.EMPTY(SEARCH_STACK)) loop 
STKJ)F_LISTS.POP(SEARCH_STACK f TEMP_LIST) ; 

STK_OF_LI STS . P USH ( SCOPE_STACK , TEMP_LIST ) ; 
end loop; 

SYMBOL_LIST. ASSIGN( PARENT. SUB_LI ST, SEARCH_SNL); 

PARENT := SNL_SEARCH( "END" ) ; 
if (PARENT /= null ) then 
LAST_FOUND ;= PARENT; 
return ( PARENT . SYMBOL ) ; 
else 

raise REFERENCE_ERROR ; 
end if; 
else 

raise REFERENCE_ERROR ; 
end if; 

end FIND_TASK_END; 

procedure UPDATE_SYM_TAB(LOCATION : in natural) is 
-- pre - The current entry is defined. 

-- post - The current entry's location is changed to LOCATION. 

TEMP_POINTER : LI ST_NODE_POINTER ; 

begin 

SYMBOL_LI ST . RETRI EVE( SEARCH_SNL , TEMP_POINTER ) ; 

TEMP_POINTER. SYMBOL. LOCATION := LOCATION; 

SYMBOL_LIST.UPDATE(SEARCH_SNL, TEMP_POINTER) ; 
end UPDATE_SYM_TAB ; 

function SELECT_COMPONENT ( KEY : in string) return SYM_TAB_ACCESS is 
-- pre - FIND_KEY or SELECT_COMPONENT returns a non-null value. 

-- post - SELECT_COMPONENT provides visibility to the next static nesting 
level below the current entry. 

If the symbol table contains an entry whose key value is KEY, 
then that entry is the current entry and FIND_KEY returns a 
pointer to that symbol table record, else FIND_KEY returns 
a null pointer and the current entry is undefined. NOTE - 
The symbol table IS case sensitive in it's comparison of keys. 
TEMP^POINTER : LISTNODEPOINTER ; 
begin 

ENTER_SEARCH_SCOPE; 

TEMP_POINTER := SNL_SEARCH( KEY ) ; 
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if (TEMP_POINTER = null) then 
LAST_FOUND := null; 
return (null); 
else 

LAST_FOUND := TEMP_POINTER ; 
return ( TEMPPOINTER . SYMBOL ) ; 
end if; 

end SELECT_COMPONENT; 

function RETRIEVE_SYM return SYM_TAB_ACCESS is 

-- post - RETRIEVE_SYM returns a pointer to the current entry or null if 
the current entry is undefined. 

TEMPPOINTER : LISTNODEPOINTER; 
begin 

if (LAST_FOUND /= null) then 
return ( LAST_FOUND . SYMBOL) ; 
else 

return (null); 
end if; 

end RETRI EVE_SYM ; 

procedure SAVE_CURRENT_ENTRY is 

-- pre - The current entry is defined; 

-- post - The current entry is saved in a last in first out data structure, 
begin 

SYMBOL _LI ST . SAVE_LI ST ( SEARCHSNL ) ; 
end SAVE_CURRENT_ENTRY; 

procedure RESTORE_CURRENT_ENTRY is 
-- pre - A current entry was saved; 

-- post - The last current entry saved is the current entry, 
begin 

SYMBOLLIST RESTORELIST ( SEARCHSNL) ; 

SYMBOL_LIST . RETRI EVE ( SEARCH_SNL , LAST_FOUND) ; 
end RESTORE_CURRENT_ENTRY; 

procedure PR INT_SYMBOL_TABLE is 

-- post - Useful as a debugging tool, PRINT_SYMBOL_TABLE prints a dump of 
every symbol table entry, including attribute and location 
information, to the standard output device. The current entry is 
undefined. 

TEMP POINTER : LIST_NODE J>01 NTER ; 

SEARCH_STACK : STK_OF_LISTS. STACK ; 

TEMP_LIST : SYMBOL_LIST .LIST; 

SUCCESS : boolean; 

procedure PRINT_RECORD( SP : in SYM_TAB_ACCESS) is 
use TEXTIO; 
beg 1 n 

new_l i ne ; 

for INDEX in 1 .. SP . NAME LENGTH loop 
put(SP.NAME( INDEX) ) ; 
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end loop; 
set_col ( 30 ) ; 

put{ SYMBOL_TAG ' I MAGE ( SP . TAG_TYPE ) ) ; 
set_col(60) ; 

put_l ine( natural' IMAGE ( SP . LOCATION ) ) ; 
end PRINT_RECORD; 
begin 

STK_OF_LI STS. CREATE (SEARCH_STACK, SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 

if (not SYMBOL_LIST . EMPTY( SYM_TAB ) ) then 
SYMB0L_LIST . FIND_F I RST( SYM_TAB) ; 

TEMP_LIST := SYM_TAB ; 
loop 

while (not SYMBOL_LIST.EMPTY(TEMP_LIST) ) loop 
STK_0F_LISTS.PUSH(SEARCH_STACK, TEMP_LIST ) ; 
SYMBOL_LIST.RETRIEVE(TEMP_LIST, TEMP_POINTER); 
TEMP_LIST := TEMP_PO INTER . SUB_LIST ; 
if (not SYMBOL_LIST . EMPTY ( TEMP_LI ST ) ) then 
SYMBOL_LIST.FIND_FIRST(TEMP_LIST); 
end if; 
end loop; 

STK_OF_LISTS.POP(SEARCH_STACK, TEMP_LIST ) ; 

SYMBOL_LI ST. RETRIEVE (TEMPJ.IST, TEMP POINTER) ; 
PRINT_RECORD( TEMP_POINTER. SYMBOL ) ; 
if (not SYMBOL_LIST . LAST (TEMP_LIST ) ) then 
SYMBOL_LIST . FIND_NEXT (TEMP_LIST ) ; 
else 

while ((not STK_OF_LISTS . EMPTY (SEARCH_ST AC K ) ) and then 
(SYMBOL_LIST.LAST(TEMP_LIST))) loop 

STK_OF_LI STS . POP ( SEARCH_STACK , TEMP_LIST ) ; 
SYMBOL_LIST . RETRIEVE( TEMP_LIST , TEMPPOINTER ) ; 
PRINT_RECORD( TEMPPOI NTER . SYMBOL ) ; 
end loop; 

exit when ( (STK_OF_LISTS . EMPTY ( SEARCH_STACK ) ) and then 
( SYMBOL_LIST . LAST(TEMP_LIST ) ) ) ; 

SYMBOL_LIST . FIND_NEXT( TEMP_LIST ) ; 
end if; 
end loop; 
end if; 

LAST_FOUND := null; 
end PRINTSYMBOLTABLE; 



beg i n 

INITIALIZE_SYM_TAB ; 
end SYMBOL_TABLE ; 
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APPENDIX F 



"ADA FLOW” PROGRAM LISTING - CODE BLOCKER 



TITLE : 


ADAFLOW 




MODULE NAME: 


PACKAGE C0DE_BL0CKER 


— 


FILE NAME: 


BLOCKER. ADS 


-- 


OATE CREATED: 


31 MAR 88 


-- 


LAST MODIFIED 


: 28 APR 88 


-- 


AUTHOR(S) : 


LT ALBERT J. GRECCO, USN 




DESCRIPTION: 


This package defines the interface to the 
CODEBLOCKER module. 


- 



with TOKEN_SCANNER; -- only for visibility of type SOURCE_RECORD 
package CODE_BLOCKER is 

CODE_BLOCKER_UNDERFLOW : exception; 

CODE_BLOCKER_OVERFLOW ; exception; 

UNMATCHED_CODE_B LOCKS : exception; 

procedure ENTER_CODE_BLOCK( SOURCE : in TOKEN_SCANNER . SOURCE_RECORD ; 

LABEL : in string); 

-- post - A unique code block number, starting with the number 1 and 
continuing sequentially, is generated and associated with 
the new code block. The current code block number is the 
new code block number. The statement count is set to zero. 

procedure INCREMENT_STATEMENT_COUNT ; 

-- pre - A code block has been entered. 

-- post - Used to count the number of statements in a code 

block. Initially zero, INCREMENT STATE ME NT_COUNT increases 
the count of statements encountered in the current 
code block by 1. 

-- exceptions raised - UNMATCHED_CODE JJLOCKS if a code block has not been 
entered. 

procedure DELETE_CODE_BLOCK_ENTER; 

-- pre - A code block has been entered. 

- post - The most recently entered code block is deleted and the state 
of the code blocker is restored to the state just prior to the 
erroneous code block entry. 

exceptions raised - UNMATCHEDCODEBLOCKS if a code block has not been 
entered. 
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function IS_CODE_BLOCK_ENTERED return boolean; 

-- pre - If a code block has been entered and not yet exited, 

IS_CODE_BLOCK_ENTERED returns true, else returns false. 

procedure EXIT_CODE_BLOCK( SOURCE : in TOKEN_SCANNER . SOURCE_RECORD ) ; 

-- pre - A code block has been entered. 

-- post - The most recently entered code block is added to a list of 

exited code blocks. The next most recently entered code block, 
if it exists, becomes the current code block. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block has not been 
entered. 

procedure REACTIVATE j:ODE_BLOCK(CODE_BLOCK_NUMBER : in positive); 

-- pre - The code block number exists in the list of exited code blocks. 

-- post - The code block is removed from the list of exited code blocks and 
made the current code block. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block does not exist 
in the list of exited code blocks with the named 
CODE_BLOCK_NUMBER. 

CODE_BLOCKER_UNDERFLOW if the block list is clear. 

function CURRENT_CODE_BLOCK_NUMBER return positive; 

-- pre - A code block has been entered and not yet exited. 

— post - CURRENT_CODE_BLOCK_NUMBER returns the number of the current, 
code block that has most recently been entered. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is 
not currently in a code block. 

function CURRENT_STATEMENT_COUNT return natural; 

-- pre - A code block has been entered. 

-- post - CURRENT_STATEMENT_COUNT returns the count of 

statements encountered in the current code block. 

-- exceptions raised - UNMATCFIED CODE BLOCKS if a code block has not been 
entered. 

procedure CLEAR_CODE_BLOCKER ; 

-- post - Clears the code blocker of all code blocks that have been entered 
and of all code blocks in the list of exited code blocks. The 
current code block number is undefined. The next code block 
number to be generated is 1. 

function IS_CODE_BLOCK_LI ST_CLEAR return boolean; 

-- post - If no code blocks have been entered and exited then 

IS_C0DE_BLOCK_LIST_CLEAR returns true, else returns false. 

function IS_LAST_CODE_BLOCK return boolean; 

-- pre - The code block list is not clear. 

-- post - If there are no other blocks of code in the list of code blocks, 

I S_LAST_CODE_BLOCK returns true, else IS_LAST_CODE_BLOCK returns 
false. 

-- exceptions raised CODE_BLOCKER UNDERFLOW if the block list is clear. 
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procedure FIND_FIRST_CODE_BLOCK; 

-- pre - The code block list is not clear and no code blocks have been 
entered and not yet exited. 

-- post - Rewinds the code block list to the first block. The current block 
in the code block list is the first block in the code block list. 
-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

procedure FIND_NEXT_CODE_BLOCK; 

-- pre - The code block list is not at the last block and is not clear. 

No code blocks have been entered and not yet exited. 

-- post - The code blocker is advanced to the next block. The current block 
in the code block list is the next block in the code block list. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

CODE_BLOCK_OVERFLOW if at the last block in the list. 
UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

function READ_CODE_BLOCK_NUMBER return positive; 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READ_CODE_BLOCK_NUMBER returns the code block number of the 
current code block in the code block list. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

function READ_CODE_BLOCK_STATEMENT_COUNT return natural; 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READ_CODE_BLOCK_STATEMENT_COUNT returns the number of 

statements recorded as encountered in the current code block 
in the code block list. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

UNMATCHED_CODE_B LOCKS if a block has been entered 
and not yet exited. 

function READ_CODE_BLOCK_START return TOKEN_SCANNER . SOURCE_RECORD ; 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

- post - READ_CODE_BLOCK_START returns the record of origin of the 

current code block in the code block list as it relates to the 
source code. 

-- exceptions raised - CODEBLOCKERUNDERFLOW if the block list is clear. 

UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

function READ_CODE_BLOCK_STOP return TOKENSCANNER .SOURCERECORD; 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 
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— post - REA0_C0DE_BL0CK_ST0P returns the record of completion of the 

current code block in the code block list as it relates to the 
source code. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is clear. 

UNMATCHEDCODEBLOCKS if a block has been entered 
and not yet exited. 

function READ_CODE_BLOCK_LABEL return string; 

— pre - The code block list is not clear. No code blocks have been 

entered and not yet exited. 

-- post - REAOCODEBLOCKLABEL returns the label entered when the 
current code block in the code block list was entered. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is clear. 

UNMATCHEO_CODE_B LOCKS if a block has been entered 
and not yet exited. 

end CODE_BLOCKER; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE CODE_BLOCKER 

-- FILE NAME: BLOCKER. ADB 



-- DATE CREATED: 31 MAR 88 

-- LAST MODIFIED: 28 APR 88 



-- AUTHOR(S) : LT ALBERT J. GRECCO, USN 



-- DESCRIPTION: This package implements the interface to the 

CODE_BLOCKER module. 



«•*»*******••**-- 



with ORDERED_GENERIC_LIST, 

GENERIC_STACK. 

UNCHECKED_DEALLOCATION, 

TOKEN_SCANNER; -- only for visibility of type S0URCE_REC0RD 
package body CODEBLOCKER is 



type CODE_BLOCK_RECORD is 



record 




BLOCK_NUMBER 


: positive; 


STATEMENT_COUNT 


: natural := 0; 


START 


: TOKEN_SCANNER.SOURCE_RECORD; 


STOP 


: TOKEN_SCANNER.SOURCE_RECORD; 


LABEL 


: st ring ( 1 . . TOKEN_SCANNER . LINE SIZE) := (others 


LABEL_LENGTH 


: natural ; 


end record; 





type CODE_BLOCK_POINTER is access CODEBLOCKRECORD ; 

NEXT_BLOCK_NUMBER : positive := 1; 

CURRENT_BLOCK_NUMBER : positive; 

package BLOCK_LIST is new ORDERED_GENERIC_LIST (C0DE_BLOC K_POINTER) ; 
package BLOCK_STACK is new GENERIC_STACK(CODE_BLOCK_POINTER ) ; 
procedure FREE_CODE_BLOCK is new 

UNC HECKEDDEAL LOCATION (CODE BLOC K_REC0RD , CODEBLOCKPOI NTER ) ; 

BL : BLOC K_LIST .LIST; 

BS : BLOCK_STACK. STACK; 

procedure INI TI ALI ZE_CODE_BLOCKER is 
SUCCESS : boolean; 
beg i n 

BLOCK_LIST . CREATE ( BL , SUCCESS); 
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if (not SUCCESS) then 

raise CODE_BLOCKER_OVERFLOW ; 
end if; 

BLOCK_STACK . CREATE ( BS, SUCCESS); 
if (not SUCCESS) then 

raise CODE BLOC KEROVERF LOW; 
end if; 

NEXT_BLOCK_NUMBER := 1; 
end INI TIALI ZE_C0DE_B LOCKER ; 

procedure ENTER_CODE_BLOCK( SOURCE ; in TOKENSCANNER . SOURCE_RECORD ; 

LABEL : in string) is 

-- post - A unique code block number, starting with the number 1 and 
continuing sequentially, is generated and associated with 
the new code block. The current code block number is the 
new code block number. 

TEMPPOINTER ; CODE_BLOCK_POINTER ; 
begin 

TEMP_POINTER ;= new C0DE_BL0CK_REC0RD ; 

TEMP_POINTER . BLOC K_NUMBER := NEXT_BLOCK_NUMBER ; 

CURRENT_BLOCK_NUMBER := NEXT_BLOCK_NUMBER ; 

NEXT_BLOCK_NUMBER := NEXT_BLOCK_NUMBER + 1; 

TEMP_POINTER .STATE MEN T_C0UNT := 0; 

TEMP_POINTER. START := SOURCE; 

TEMP_POINTER. LABEL := (others *> ' '); 

TEMP_P0INTER . LABEL ( 1 . . LABEL ' LAST ) := LABEL; 

TEMP_POINTER.LABEL_LENGTH := LABEL * LENGTH ; 

BLOCK_STACK . PUSH( BS , TEMP_POINTER ) ; 
end ENTER_CODE_BLOCK ; 

procedure INCREMENT_STATEMENT_COUNT is 
-- pre - A code block has been entered. 

-- post - Used to count the number of statements in a code 

block. Initially zero, INCREMENT _STATEMENT_COUNT increases 
the count of statements encountered in the current 
code block by 1. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block has not been 
entered. 

TEMPPOINTER : C0DE_BL0CK_P0INTER; 
begin 

if ( BLOCK_STACK . EMPTY ( BS ) ) then 
raise UNMATCHED_CODE_BLOCKS; 
else 

BLOCK_STACK.POP(BS, TEMPPOINTER) ; 

TEMPPOINTER. STATEMENT COUNT ;= 

natural ' SUCC( TEMPPOINTER . STATEMENT_COUNT ) ; 
BLOCK_STACK . PUSH( BS , TEMP _PDINTER) ; 
end if; 

end INCREMENT_STATEMENT_CDUNT ; 



205 



procedure DELETE_CODE_BLOCK_ENTER is 
-- pre - A code block has been entered. 

-- post - The most recently entered code block is deleted and the state 
of the code blocker is restored to the state just prior to the 
erroneous code block entry. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block has not been 
entered. 

TEMPPOINTER : CODE_BLOCK_POINTER ; 
begin 

if ( BLOC K_STACK . EMPTY ( BS ) ) then 
raise UNMATCHED_CODE_BLOCKS ; 
else 

BLOCK_STACK.POP(BS, TEMPPOINTER ) ; 

FREE_CODE_BLOCK(TEMP_POINTER); 

NEXT_BLOCK_NUMBER := NEXT_BLOCK_NUMBER - 1; 
if (not BLOCK_STACK . EMPTY( BS ) ) then 
BLOCK_STACK . T0P( BS, TEMP_POINTER) ; 

CURRENT_BLOCK_NUMBER := TEMPPOINTER . BLOCK_NUMBER ; 
end i f ; 
end if; 

end DELETE_CODE_BLOCK_ENTER ; 

function ISCODEBLOCKENTERED return boolean is 
— pre - If a code block has been entered and not yet exited, 

IS_CODE_BLOCK_ENTERED returns true, else returns false. 

begin 

return (not BLOCK_STACK . EMPTY(BS) ) ; 
end IS_CODE_BLOCK_ENTERED; 

procedure EXIT_CODE_BLOCK(SOURCE : in TOKEN_SCANNER . SOURCE_RECORD ) is 

-- pre - A code block has been entered. 

-- post - The most recently entered code block is added to a list of 

exited code blocks. The next most recently entered code block, 
if it exists, becomes the current code block. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block has not been 
entered. 

TEMP_POINTER : CODE_BLOCK_POINTER ; 
begin 

if ( BLOCK_STACK . EMPTY ( BS ) ) then 
raise UNMATCHEDCODEBLOCKS ; 
el se 

BLOCK_STACK.POP(BS, TEMP_POINTER ) ; 

TEMP_POINTER .STOP := SOURCE; 

BLOCK_LIST.INSERT(BL, TEMPPOI NTER , TEMP_POINTER . BLOCK JJUMBE R ) ; 
if (not BLOCK_STACK.EMPTY(BS) ) then 
BLOCK_STACK . TOP( BS , TEMP_POINTER ) ; 

CURRENT_BLOC KNUMBER := TEMP_POINTER . BLOCK_NUMBER ; 
end if; 
end if; 

end EXIT CODE BLOCK; 
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procedure REACTIVATE_COOE_BLOCK( CODE_BLOC K_NUMBER : in positive) is 
-- pre - The code block number exists in the list of exited code blocks. 

-- post - The code block is removed from the list of exited code blocks and 
made the current code block. 

-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block does not exist 
in the list of exited code blocks with the named 
CODE_BLOCK_NUMBER. 

CODEBLOCKERUNDERFLOW if the block list is clear. 
TEMP_POINTER : CODE_BLOCK_POINTER ; 
begin 

if (BLOCK_LIST . EMPTY ( BL) ) then 
raise C0DE_8L0CKER_UNDERFL0W; 
el se 

BLOCK_LIST.FINO_FIRST(BL); 

BLOC K_L 1ST. RETRIEVE(BL, TEMP_POINTER ) ; 

while (TEMP_POINTER.BLOCK_NUMBER /= CODE_BLOCK_NUMBER) loop 
if (BLOCK_LIST . LAST ( BL ) ) then 
raise UNMATCHEDCODEBLOCKS ; 
else 

BLOCK_LIST . FI ND_NEXT(BL) ; 

BLOCK_LIST . RETRIEVE(BL , TEMP_POINTER ) ; 
end if; 
end loop; 

BLOCK_LIST . DELETE ( BL ) ; 

BLOCK_STACK.PUSH(BS, TEMP_POINTER) ; 

CURRENT_BLOCK_NUMBER := COOE_BLOCK_NUMBER ; 
end if; 

end REACTIVATE_CODE_BLOCK ; 

function CURRENT_CODE_BLOCK_NUMBER return positive is 
-- pre - A code block has been entered and not yet exited. 

— post - CURRENT_CODE_BLOCK_NUMBER returns the number of the current, 

code block that has most recently been entered. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is 
not currently in a code block. 

begin 

if ( BLOCK_STACK . EMPTY ( BS ) ) then 
raise CODE_BLOCKER_UNDERFLOW ; 
else 

return (CURRENT_BLOCK_NUMBER) ; 
end if; 

end CURRENT_CODE_8LOC K_NUMBER; 

function CURRENT_STATEMENT_COUNT return natural is 

— pre - A code block has been entered. 

-- post - CURRENT_STATEMENT_COUNT returns the count of 

statements encountered in the current code block. 

-- exceptions raised - UNMATCHEDCODEBLOCKS if a code block has not been 
entered. 

TEMP POINTER : CODE_BLOCK_POINTER ; 
begin 
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if ( BLOCK_STACK . EMPTY ( BS ) ) then 
raise UNMATCHED_CODE_BLOCKS ; 
el se 

BLOCK_STACK.TOP(BS, TEMP_POINTER ) ; 
return ( TEMP_POINTER. STATEMENT_COUNT ) ; 
end if; 

end CURRENT_STATEMENT_COUNT ; 
procedure CLEAR_CODE_BLOCKER is 

-- post - Clears the code blocker of all code blocks that have been entered 
and of all code blocks in the list of exited code blocks. The 
current code block number is undefined. The next code block 
number to be generated is 1. 

TEMPPOINTER : COOE_BLOCK_POINTER ; 
begin 

while (not BLOCK_LIST . EMPTY ( BL ) ) loop 
BLOCK_LIST.RETRIEVE(BL, TEMPPOINTER ) ; 

FREE_CODE_BLOCK{ TEMPPOINTER) ; 

BLOCK_LIST.DELETE(BL); 
end loop; 

while (not BLOCK_STACK . EMPTY ( BS) ) loop 
BLOCK_STACK.POP(BS, TEMP_POINTER ) ; 

FREE_CODE_BLOCK(TEMP_POINTER); 
end loop; 

NEXT_BLOCK_NUMBER := 1; 
end CLEAR_CODE_BLOCKER ; 

function IS_CODE_BLOCK_LIST_CLEAR return boolean is 

-- post - If no code blocks have been both entered and exited then 

I S_CODE_BLOC K_LI ST_CLEAR returns true, else returns false. 

beg in 

return (BLOCK_LIST.EMPTY(BL ) ) ; 
end IS_CODE_BLOCK_LIST_CLEAR; 

function IS_LAST_CODE_BLOCK return boolean is 
-- pre - The code block list is not clear. 

-- post - If there are no other blocks of code in the list of code blocks, 
IS_LAST_CODE_BLOCK returns true, else IS_LAST_CODE_BLOCK returns 
false. 

-- exceptions raised - CODEBLOCKERUNDERFLOW if the block list is clear, 
beg i n 

if ( BLOCK_LIST . EMPTY ( BL ) ) then 
raise CODE_B LOCKE R_UNDER FLOW; 
el se 

return ( BLOC K_L 1ST . LAST ( BL ) ) ; 
end if; 

end I SLASTCOOEBLOCK ; 
procedure F I ND_F IRST_CODE_BLOCK is 

- pre - The code block list is not clear and no code blocks have been 
entered and not yet exited. 
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-- post - Rewinds the code block list to the first block. The current block 
in the code block list is the first block in the code block list. 
— exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

UNMATCHEDCODEBLOCKS if a block has been entered 
and not yet exited. 

begin 

if ( BLOCK_LIST . EMPTY ( BL ) ) then 
raise CODE_BLOCKER_UNDERFLOW; 
elsif (not BLOCK_STACK . EMPTY ( BS ) ) then 
raise UNMATCHED_CODE_BLOCKS; 
el se 

BLOCK_LIST.FIND_FIRST(BL); 
end if; 

end FIND_FIRST_CODE_BLOCK; 
procedure FIND_NEXT_CODE_BLOCK is 

-- pre - The code block list is not at the last block and is not clear. 

No code blocks have been entered and not yet exited. 

-- post - The code blocker is advanced to the next block. The current block 
in the code block list is the next block in the code block list. 

-- exceptions raised - CODE_BLOCKER JJNDERFLOW if the block list is clear. 

CODE_BLOCK_OVERFLOW if at the last block in the list. 
UNMATCH ED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

begin 

if ( BLOCK_LIST . EMPTY ( BL) ) then 
raise CODE_BLOCKER_UNDERFLOW ; 
elsif ( BLOCKLIST . LAST ( BL ) ) then 
raise CODE_BLOC K E R_OVE R F LOW ; 
elsif (not BLOCK_STACK . EMPTY ( BS) ) then 
raise UNMATCHED_CODE_BLOCKS; 
else 

BLOCK_LIST . F IND_NEXT ( BL) ; 
end if; 

end FIND_NEXT_CODE_BLOCK ; 

function READCODEBLOCKNUMBER return positive is 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READCODEBLOCKNUMBER returns the code block number of the 
current code block in the code block list. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 

UNMATCHEDCODEBLOCKS if a block has been entered 
and not yet exited. 

TEMPPOINTER : CODE_BLOCK_POINTER ; 
begin 

if ( BLOCK_LIST . EMPTY ( BL ) ) then 
raise CODE_BLOCKER_UNDERFLOW ; 
elsif (not BLOCK_STACK . EMPTY (BS) ) then 
raise UNMATCHED_CODE BLOCKS; 
else 
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BLOC K L 1ST . RETRI EVE( BL , TEMP_POI NTER ) ; 

return ( TEMP_POINTER . BLOCK_NUMBER ) ; 
end if; 

end READ_CODE_BLOCK_NUMBER; 

function READ_CODE_BLOCK_STATEMENT_COUNT return natural is 
-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READ_CODE_BLOCK_STATEMENT_COUNT returns the number of 

statements recorded as encountered in the current code block 
in the code block list. 

-- exceptions raised - CODEBLOCKERUNDERFLOW if the block list is clear. 

UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

TEMP_POINTER : C0DE_BL0CK_P0INTER ; 
begin 

if (BL0CK_LIST.EMPTY( BL ) ) then 
raise COOE_BLOCKER_UNDERFLOW; 
elsif (not BLOCK_STACK.EMPTY(BS) ) then 
raise UNMATCHED_CODE_BLOCKS; 
el se 

BLOCK_LIST . RETRI EVE (BL , TEMP_P0INTER) ; 
return ( TEMP_POlNTER . STATEMENT_COUNT ) ; 
end if; 

end READ_CODE_BLOCK_STATEMENT_COUNT ; 

function READ_CODE_BLOCK_START return TOKEN_SCANNER . SOURCE_RECORD is 
-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READ_CODE_BLOCK_START returns the record of origin of the 

current code block in the code block list as it relates to the 
source code. 

-- exceptions raised - CODEBLOCKERUNDERFLOW if the block list is clear. 

UNMATCHEDCODEBLOCKS if a block has been entered 
and not yet exited. 

TEMP_POINTER : CODE_BLOCK_POINTER ; 
begin 

if (BLOCKLIST.EMPTY(BL) ) then 
raise CODE_BLOCKER_UNDERFLOW; 
elsif (not BLOCK_STACK . EMPTY (BS ) ) then 
raise UNMATCHEDCODEBLOCKS; 
else 

BLOCKLI ST. RETRI EVE (BL, TEMPPOINTER) ; 
return ( TEMP_POINTER . START ) ; 
end if; 

end READ_CODE_BLOCK_START ; 

function READ_CODE_BLOCK_STOP return TOKEN_SCANNER . SOURCE_RECORD is 
pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

post - READCODEBLOCK STOP returns the record of completion of the 
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current code block in the code block list as it relates to the 
source code. 

-- exceptions raised - CODEBLOCKERUNDERFLOW if the code blocker is clear. 

UNMATCHED_CODE_BLOCKS if a block has been entered 
and not yet exited. 

TEMPPOINTER : CODE_BLOCK_POINTER ; 
begin 

if { BLOCK_LIST . EMPTY (BL ) ) then 
raise CODE_BLOCKER_UNDERFLOW ; 
elsif (not BLOCK_STACK.EMPTY(BS) ) then 
raise UNMATCHED_CODE_BLOCKS ; 
else 

BLOCK_LIST . RETRI EVE ( BL , TEMPPOINTER ) ; 
return ( TEMP_POINTER . STOP ) ; 
end if; 

end READ_CODE_BLOCK_STOP; 

function READ_CODE_BLOCK_LABEL return string is 

-- pre - The code block list is not clear. No code blocks have been 
entered and not yet exited. 

-- post - READ_CODE_BLOCK_LABEL returns the label entered when the 
current code block in the code block list was entered. 

-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is clear. 

UNMATCHEDCODEBLOCKS if a block has been entered 
and not yet exited. 

TEMP_POINTER : CODE_BLOCK_POINTER ; 
begin 

if (BLOCK_LIST . EMPTY (BL ) ) then 
raise CODE_BLOCKER_UNDERFLOW ; 
elsif (not BLOCK_ST AC K. EMPTY (BS) ) then 
raise UNMATCHED_CODE_BLOCKS; 
el se 

BLOCK_LIST . RETRI EVE ( BL , TEMP_POINTER) ; 

return ( T EMP_POI N TER. LABE L( 1. . TEMP_POINTER . LABEL_LENGTH ) ) ; 
end if; 

end READ_CODE_BLOCK_LABEL; 
begin 

INITIALI ZE_CODE_BLOCKER ; 
end CODE_BLOCKER ; 
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APPENDIX G 



"ADAFLOW” PROGRAM LISTING - TOKEN MATCHER 



-- TITLE: ADAFLOW 

-- MODULE NAME: PACKAGE TOKEN_MATCHER 

-- FILE NAME: MATCH. ADS 

— DATE CREATED: 18 FEB 88 

-- LAST MODIFIED: 28 APR 88 

-- AUTHOR(S) : LT ALBERT J. GRECCO, USN 

-- DESCRIPTION: This package defines the interface to the 

module that identifies each individual 
token and manages the TOKEN_SCANNER The 
TOKEN_MATCHER is the sole manager of the 
TQKEN_SCANNER interface and all access to the 
TOKEN_SCANNER interface is through T0KEN_ 

MATCHER. This restriction does not apply to 
types specified in the TOKEN SCANNER 
interface. Types specified in the T0KEN_ 

SCANNER interface are available for global use.-- 



with TOKEN_SCANNER; 
package TOKEN_MATCHER is 

-- The following token codes define the terminals of the ADA language. 



basic tokens 


TOKEN_IDENTIFIER 


constant integer 


= 1; 


TOKEN_NUMERIC_LI TERAL 


constant integer 


= 2; 


TOKEN_CHARACTER_LITERAL 


constant integer 


= 3; 


TOKEN_STRING_Ll TERAL 


constant integer 


= 4; 


reserved word tokens 


T0KEN_END 


: constant integer : 


:= 5; 


TOKEN_BEGI N 


: constant integer : 


: - 6 ; 


TOKENIF 


: constant integer ; 


:= 7; 


TOKEN_THEN 


: constant integer : 


:= 8; 


TOKEN ELSIF 


: constant integer : 


:= 9; 


TOKENELSE 


: constant integer : 


:= 10 
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T0KEN_WHILE 

TOKEN_LOOP 

TOKENCASE 

TOKEN_WHEN 

TOKENDECLARE 

TOKENFOR 

TOKENOTHERS 

TOKENRETURN 

TOKEN_EXIT 

TOKENPROCEDURE 

TOKEN_FUNCT ION 

T0KEN_WITH 

TOKEN_USE 

TOKEN_PACKAGE 

TOKEN_BODY 

TOKEN_RANGE 

TOKEN_IN 

TOKENOUT 

TOKEN_SUBTYPE 

TOKENTYPE 

TOKEN_IS 

TOKEN_NULL 

TOKEN_ACCESS 

TOKEN_ARRAY 

TOKEN_DIGITS 

TOKEN_DELTA 

TOKEN_RECORD_STRUCTURE 

TOKEN_CONSTANT 

TOKEN_NEW 

TOKEN_EXCEPTION 

TOKEN_RENAMES 

TOKEN_PRIVATE 

TOKEN_LIMI TED 

TOKEN_TASK 

TOKEN_ENTRY 

TOKEN_ACCEPT 

TOKEN_DELAY 

TOKEN_SELECT 

TOKEN_TERMINATE 

TOKEN_ABORT 

TOKEN_SEPARATE 

TOKEN_RAISE 

TOKEN_GENERIC 

TOKEN_AT 

TOKEN_REVERSE 

TOKEN_DO 

TOKEN_GOTO 

TOKEN_OF 

TOKENALL 

TOKEN PRAGMA 

TOKENING 



constant integer 


= 11 


constant integer 


= 12 


constant integer 


= 13 


constant integer 


= 14 


constant integer 


= 15 


constant integer 


= 16 


constant integer 


= 17 


constant integer 


= 18 


constant integer 


= 19 


constant integer 


= 20 


constant integer 


= 21 


constant integer 


= 22 


constant integer 


= 23 


constant integer 


= 24 


constant integer 


= 25 


constant integer 


= 26 


constant integer 


= 27 


constant integer 


= 28 


constant integer 


= 29 


constant integer 


= 30 


constant integer 


= 31 


constant integer 


= 32 


constant integer 


= 33 


constant integer 


= 34 


constant integer 


= 35 


constant integer 


= 36 


constant integer 


= 37 


constant integer 


= 38 


constant integer 


= 39 


constant integer 


= 40 


constant integer 


= 41 


constant integer 


= 42 


constant integer 


= 43 


constant integer 


= 44 


constant integer 


= 45 


constant integer 


= 46 


constant integer 


= 47 


constant integer 


= 48 


constant integer 


= 49 


constant integer 


= 50 


constant integer 


= 51 


constant integer 


= 52 


constant integer 


= 53 


constant integer 


= 54 


constant integer 


= 55 


constant integer 


= 56 


constant integer 


= 57 


constant integer 


= 58 


constant integer 


= 59 


constant integer 


= 60 


constant integer 


= 61 
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TOKEN 


.OR 


; constant 


integer 


: = 


62 


TOKEN 


.NOT 


: constant 


i nteger 


: = 


63 


TOKEN 


XOR 


: constant 


integer 


; = 


64 


TOKEN 


MOD 


: constant 


integer 


: = 


65 


TOKEN 


.REM 


: constant 


integer 


: = 


66 


TOKEN 


.ABSOLUTE 


: constant 


integer 


: = 


67 


del imi ter tokens 










TOKEN 


.ASTERISK 


constant 


integer 


: = 


68 


TOKEN 


.SLASH 


constant 


integer 


: = 


69 


TOKEN 


.EXPONENT 


constant 


integer 


: = 


70 


TOKEN. 


.PLUS 


constant 


integer 


: = 


71 


TOKEN. 


.MINUS 


constant 


integer 


: = 


72 


TOKEN 


AMPERSAND 


constant 


integer 


: = 


73 


TOKEN. 


.EQUALS 


constant 


integer 


: = 


74 


TOKEN. 


_NOT_EQUALS 


constant 


integer 


: = 


75 


TOKEN. 


_LESS_THAN 


constant 


integer 


: = 


76 


TOKEN. 


_LESS_THAN_EQUALS 


constant 


integer 


: = 


77 


TOKEN 


_GREATER_THAN 


constant 


integer 


: = 


78 


TOKEN 


_GREATER_THAN_EQUALS 


constant 


integer 


: = 


79 


TOKEN. 


.ASSIGNMENT 


constant 


integer 


: = 


80 


TOKEN. 


.SEMICOLON 


constant 


integer 


: = 


81 


TOKEN. 


.PERIOD 


constant 


integer 


: = 


82 


TOKEN 


_LEFT_PAREN 


constant 


integer 


: = 


83 


TOKEN. 


_RIGHT_PAREN 


constant 


integer 


: = 


84 


TOKEN 


.COLON 


constant 


integer 


: = 


85 


TOKEN. 


COMMA 


constant 


integer 


: = 


86 


TOKEN 


.APOSTROPHE 


constant 


integer 


: = 


87 


TOKEN 


_RANGE_DOTS 


constant 


integer 


; = 


88 


TOKEN 


.ARROW 


constant 


integer 


: = 


89 


TOKEN 


BAR 


constant 


integer 


: = 


90 


TOKEN 


BRACKETS 


constant 


integer 


: = 


91 


TOKEN. 


_LEFT_BRACKET 


constant 


integer 


: = 


92 


TOKEN 


_RIGHT_BRACKET 


constant 


integer 


: = 


93 



procedure SET_UP_TOKEN_MATCHER( FILE_NAME : string); 

-- pre - must be called before any of the defined interfaces in 

TOKENMATCHER are invoked. Any previously set up FILE_NAME 
must be released by RELEASETOKENSCANNER . 

-- post - the TOKENMATCHER interfaces are defined. 

procedure RELEASE_TOKEN_MATCHER ; 

-- pre - TOKENMATCHER has been set up. 

-- post - all TOKEN MATCHER interfaces are undefined with the 
exception of SET_UP_TOKEN_MATCHER . 

TOKENMATCHER may be set up for another FILENAME. The 
TOKENMATCHER must be released prior to main program 
termination . 



function MATCH( TOKENCODE : in positive) return boolean; 

- pre - TOKEN MATCHER has been set up. 

- post - if the current token under the read head of the TOKENSCANNER 
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matches the TOKENCOOE then MATCH is TRUE and the read head of 
the TOKEN_SCANNER is advanced one token. Else MATCH is FALSE 
and the read head of the TOKEN_SCANNER does not advance. 

procedure MATCHEO_TOKEN( TOKEN : out TOKEN_SCANNER . TOKEN_RECORD_TYPE ) ; 

-- pre - TOKENMATCHER has been set up and at least one call to the 
function MATCH has returned TRUE. 

-- post - TOKEN contains the token that caused the last call to MATCH 
to be TRUE. NOTE - All identifiers are converted to upper 
case by the token matcher and all reserved words are converted 
to lower case by the token matcher regardless of original format 
in the source code. All other token types are left in original 
source code format. 

procedure CURRENT_TOKEN( TOKEN : out TOKEN_SCANNER . TOKEN_RECORO_TYPE ) ; 

-- pre - TOKENMATCHER has been set up. 

— post - TOKEN contains the token that is under the TOKEN_SCANNER ' s 

read head. 

procedure NEXT_TOKEN( TOKEN : out TOKEN_SCANNER . TOKEN_RECORO_TYPE ) ; 

-- pre - TOKEN_MATCHER has been set up. 

-- post - TOKEN contains the token that is next to be read by the 
TOKEN_SCANNERS read head. 

function LINE$_CHECKED return positive; 

— pre - TOKEN_MATCHER has been set up. 

-- post - returns the number of lines of code that have been checked 
by the TOKEN_MATCHER . 

function VALIOCOMMENTS return natural; 

-- pre - TOKEN_MATCHER has been set up. 

-- post - returns the number of "meaningful" comments seen by the 

TOKENMATCHER . A "meaningful" comment is defined as a comment 
that contains at least one letter or digit. 

end TOKEN_MATCHER ; 
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TITLE: 



ADAFLOW 



MODULE NAME: PACKAGE TOKEN_MATCHER 

FILE NAME: MATCH. ADB 



DATE CREATED: 18 FEB 88 

LAST MODIFIED: 28 APR 88 



AUTHOR(S): 



LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package implements the interface to the 



module that identifies each individual 
token and manages the TOKEN_SCANNER . The 
TOKENMATCHER is the sole manager of the 
TOKENSCANNER interface and all access to the -- 
TOKEN_SCANNER interface is through TOKEN_ 

MATCHER. This restriction does not apply to 
types specified in the TOKEN SCANNER 
interface. Types specified in the TOKEN_ 

SCANNER interface are available for global use.-- 



procedure SET JJP_TOKEN_MATCHER( FILENAME : string) is 

-- pre - must be called before any of the defined interfaces in 



TOKENMATCHER are invoked. Any previously set up FILENAME 
must be released by RELEASE_TOKEN_SCANNER . 



-- post - the TOKENMATCHER interfaces are defined, 
begin 

TEXT_IO . open( SOURCE_F ILE , TEXT_IO. in_f i le, FI LE_NAME , 
TEXTIO. reset ( SOURCE _FI LE ) ; 

TOKEN_SCANNER . SET_UP_TOKEN_SCANNER( SOURCE_FILE ) ; 
end SET_UP_TOKEN_MATCHER ; 

procedure RELEASE_TOKEN_MATCHER is 
-- pre - TOKEN_MATCHER has been set up. 

-- post - all TOKENMATCHER interfaces are undefined with the 



exception of SETUP^TOKEN MATCHER. 

TOKENMATCHER may be set up for another FILE_NAME. the 
TOKEN MATCHER must be released prior to main program 
termination . 



with TOKEN_SCANNER, TEXT_IO 



package body TOKENMATCHER is 



SOURCE_FI LE 
HOLD_TOKEN 



: TEXT_IO. f i letype ; 

: TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 



begin 
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TOKEN_SCANNER.RELEASE_TOKEN_SCANNER(SOURCE_FILE); 
end RELEASE_TOKEN_MATCHER; 

function MATCH( TOKENCODE : in positive) return boolean is 
-- pre - TOKEN_MATCHER has been set up. 

-- post - if the current token under the read head of the TOKENSCANNER 
matches the T0KEN_C0DE then MATCH is true and the read head of 
the TOKENSCANNER is advanced one token. Else MATCH is false 
and the read head of the TOKEN_SCANNER does not advance, 
use TOKEN_SCANNER; 
subtype BASIC_TOKENS is 

positive range TOKEN_IDENTI FIER . . TOKEN_STRI NG_LI TERAL ; 
subtype RESERVED_TOKENS is 

positive range TOKEN_END . . TOKENABSOLUTE ; 
subtype DELIMITER_T0KENS is 

positive range TOKEN_ASTERI SK . . T0KEN_RIGHT_BRACKET ; 
CURRENT_TOKEN : TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

TEST_TOKEN : TOKENSCANNER. TOKEN_RECORD_TYPE ; 

I S_SAME : boolean := FALSE; 

function ASSI6N( TEST_STRIN6 : in string) return 

TOKEN_SCANNER.TOKEN_RECORD_TYPE is 
TEMP_TOKEN ; TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 
begin 

TEMP_TOKEN.LEXEME_SIZE := TEST_STRING ' LENGTH ; 

TEMP_TOKEN. LEXEME : = (others => ' '); 

TEMP_TOKEN . LEXEME ( 1 . . TEST_STRING 1 LAST) := TEST_STRING; 

TEMP_TOKEN. SOURCE := CURRENT_TOKEN . SOURCE ; 
if ( TOKEN_CODE in RESERVED_TOKENS) then 

TEMP_TOKEN . TOKEN_TYPE := TOKEN_SCANNER . RESERVED_WORD ; 
elsif (TOKENCODE in DELIMITER_TOKENS) then 

TEMP_TOKEN.TOKEN_TYPE : = TOKENSCANNER .DELIMITER; 
end if; 

return TEMP_TOKEN ; 
end ASSIGN; 

procedure CONVERT_UPPER_CASE( TOKEN : 

in out TOKEN_SCANNER.TOKEN_RECORD_TYPE) is 
subtype UPPER_CASE_LETTER is character range ' A' . . ’ Z ' ; 
subtype LOWER_CASE_LETTER is character range 'a’..' 2 '; 
begin 

for LEXEME_INDEX in 1 .. TOKEN . LEXEME_SIZE loop 

if TOKEN. LEXEME(LEXEME_INDEX) in LOWER_CASE_LETTER then 
TOKEN. LEXEME ( LEXEMEINDEX ) : = 

UPPER_CASE_LETTER 'VAL( LOWE R_CASE_LET TER ' POS( 

TOKEN. LEXEME ( LEXEME_ INDEX ) ) - 32); 
end if; 
end loop; 

end CONVERT_UPPER_CASE ; 
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procedure CONVERT_LOWER_CASE( TOKEN : 

in out TOKEN_SCANNER.TOKEN_RECORD_TYPE) is 
subtype UPPER_CASE_LETTER is character range ' A * . . * Z * ; 
subtype LOWER_CASE_LETTER is character range ’a’.^z'; 
begin 

for LEXEMEINDEX in 1 .. TOKEN . LEXEME_SIZE loop 

if TOKEN. LEXEME(LEXEME_INDEX) in UPPER_CASE_LETTER then 
TOKEN . LEXEME ( LEXEME_INDEX ) := 

LOWER_CASE_LETTER ' VAL( UPPER_CASE_LETTER ' POS( 

TOKEN. LEXEME(LEXEME_INDEX)) + 32); 
end if; 
end loop; 

end CONVERT_LOWER_CASE; 
begin 

TOKEN_SCANNER . LOOK_TOKEN( S0URCE_F ILE , CURRENT_TOKEN) ; 
if (TOKEN_CODE in BASIC_TOKENS) then 
case T0KEN_C0DE is 

when T0KEN_I0ENTI TIER => 

ISSAME := ( CURRENT_TOKEN . TOKENTYPE = TOKEN_SCANNER . IDENTIFIER); 
if ( IS_SAME ) then 

CONVERT_UPPER_CASE(CURRENT_TOKEN); 
end if; 

when TOKEN_NUMERIC_LITERAL => 

IS_SAME := ( CURRENT_TOKEN . TOKEN_TYPE = TOKEN_SCANNER . NUMERIC_LIT) ; 
when TOKEN_CHARACTER_LI TERAL => 

IS_SAME ;= (CURRENT_TOKEN.TOKEN_TYPE = TOKEN_SCANNER . CHARACTER_LIT ) ; 
when TOKEN_STRING_LITERAL => 

IS_SAME ;= (CURRENT_TOKEN.TOKEN_TYPE = TOKEN_SCANNER . STRING_LIT ) ; 
when others => nul 1 ; 
end case; 
else 

CONVERT_LOWER_CASE(CURRENT_TOKEN); 
case TOKEN_CODE is 
when T0KEN_END => 

TEST_TOKEN := ASSIGN (" end" ) ; 
when TOKEN_BEGIN => 

TEST_TOKEN := ASSIGN( "begin" ) ; 
when TOKEN_I F => 

TEST_TOKEN := ASSIGN( " i f ” ) ; 
when TOKEN_THEN => 

TEST_TOKEN := ASSIGN( "then" ) ; 
when TOKENELSIF => 

TESTTOKEN ;= ASSIGN( "el s i f " ) ; 
when TOKEN_ELSE => 

TEST_TOKEN := ASSIGN( "el se" ) ; 
when TOKENWHILE => 

TEST_TOKEN := ASSIGN( "wh i 1 e" ) ; 
when TOKENLOOP -> 

TESTTOKEN := ASSIGN( ” 1 oop" ) ; 
when TOKEN CASE => 

TESTTOKEN := ASSIGN( "case" ) ; 
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when TOKEN_WHEN => 

TEST_TOKEN := ASSIGN( "when" > ; 
when TOKEN_DECLARE => 

TEST_TOKEN := ASSIGN( "decl are" ) ; 
when TOKEN_FOR => 

TEST_TOKEN := ASSIGN( " f or" ) ; 
when TOKEN_OTHERS => 

TEST_TOKEN := ASSIGN( "others" ) ; 
when TOKEN_RETURN => 

TEST_TOKEN := ASSIGN( " return" ) ; 
when TOKEN_EXIT => 

TEST_TOKEN := ASSIGN( "ex i t" ) ; 
when TOKEN_PROCEDURE => 

TEST_TOKEN := ASSIGN( "procedure" ) ; 
when TOKEN_FUNCTION => 

TEST_TOKEN := ASSIGN( "function" ) ; 
when TOKEN_WITH => 

TEST_TOKEN := ASSIGN( "wi th" ) ; 
when TOKENJJSE => 

TEST_TOKEN := ASSIGN( "use" ) ; 
when TOKEN_PACKAGE => 

TEST_TOKEN := ASSIGN( "package" ) ; 
when TOKEN_BODY => 

TEST_TOKEN := ASSIGN( "body " ) ; 
when TOKEN_RANGE => 

TEST_TOKEN := ASSIGN( " range” ) ; 
when TOKEN_IN => 

TEST_TOKEN := ASSIGN( "in" ) ; 
when TOKEN_OUT => 

TEST_TOKEN := ASSIGN( "out" ) ; 
when TOKEN_SUBTYPE => 

TEST_TOKEN := ASSIGN( "subtype" ) ; 
when TOKEN_TYPE => 

TEST_TOKEN := ASSIGN( " type" ) ; 
when TOKEN_I S => 

TEST_TOKEN := ASSIGN* " is" ) ; 
when TOKEN_NULL => 

TEST_TOKEN := ASSIGN( "nul 1 " ) ; 
when TOKEN_ACCESS => 

TEST_TOKEN := ASSIGN( "access" ) ; 
when TOKEN_ARRAY => 

TEST_TOKEN := ASSIGN* "array" ) ; 
when TOKEN_DIGI TS => 

TESTTOKEN := ASSIGN* "d ig l ts" ) ; 
when TOKENDELTA => 

TEST_TOKEN := ASSIGN( "del ta" ) ; 
when TOKEN_RECORD_STRUCTURE => 
TEST_TOKEN := ASSIGN (" record” ) ; 
when TOKENCONSTANT => 

TEST^TOKEN := ASSIGN( "constant" ) ; 
when TOKEN NEW => 
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TES T_T OKEN := ASSIGN( " new” ) ; 
when TOKEN_EXCEPTION => 

TEST_TOKEN := ASSIGN( "exception" ) 
when TOKEN_RENAMES => 

TEST_TOKEN := ASSIGN( " renames" ) ; 
when TOKENPRIVATE => 

TEST_TOKEN := ASSIGN( "private" ) ; 
when TOKEN_LIMITED => 

TEST_TOKEN := ASSIGN( " 1 imited" ) ; 
when TOKEN_TASK => 

TEST_TOKEN := ASSIGN( "task" ) ; 
when TOKEN_ENTRY => 

TEST_TOKEN := ASSIGN( "entry" ) ; 
when TOKEN_ACCEPT => 

TEST_TOKEN := ASSIGN( "accept" ) ; 
when TOKEN_DELAY => 

TEST_TOKEN := ASSIGN( "del ay " ) ; 
when TOKENSELECT => 

TESTTOKEN := ASSIGN( "select" ) ; 
when TOK EXTERMINATE => 

TEST_TOKEN := ASSIGN( "terminate") 
when TOKENABORT => 

TEST_TOKEN := ASSIGN( "abort" ) ; 
when TOKEN_SEPARATE => 

TEST_TOKEN := ASSIGN( "separate" ) ; 
when TOKENRAISE => 

TEST_TOKEN := AS$IGN( ” raise" ) ; 
when TOKEN_GENERIC => 

TEST_TOKEN := ASSIGN( "generic" ) ; 
when TOKEN AT = > 

TEST_TOKEN := ASSIGN( "at" ) ; 
when TOKEN_REVERSE => 

TEST_TOKEN := ASSIGN( ” reve rse" ) ; 
when T0KEN_D0 => 

TEST_TOKEN := ASSIGN( " do" ) ; 
when TOKEXGOTO => 

TEST_TOKEN := ASSIGN( "goto" ) ; 
when T0KEN_0F => 

TEST_TOKEN := ASSIGN( "of " ) ; 
when T0KEN_ALL => 

TEST TOKEN := ASSIGN( "al 1 " ) ; 
when TOKEN_PRAGMA => 

TEST_TOKEN := ASSIGN( "pragma" ) ; 
when T0KEN_AND => 

TEST TOKEN := ASSIGN( "and" ) ; 
when T0KEN_0R => 

TESTTOKEN := ASSIGN( "or" ) ; 
when TOKEN_NOT => 

TESTTOKEN := ASSIGN( "not" ) ; 
when TOKEN XOR => 

TEST_TOKEN := ASSIGN( " xor" ) ; 



when TOKEN_MOD => 

TEST_TOKEN := ASSIGN* "mod" ) ; 
when TOKEN_REM => 

TEST_TOKEN := ASSIGN* " rem" ) ; 
when TOKENABSOLUTE => 

TEST_TOKEN := ASSIGN* "abs" ) ; 
when TOKEN_ASTERISK => 

TEST_TOKEN := ASSIGN*"*"); 
when TOKEN_SLASH => 

TEST_TOKEN := ASSIGN*"/"); 
when TOKENEXPONENT => 

TEST_TOKEN := ASSIGN* "*•") ; 
when TOKEN_PLUS => 

TEST_TOKEN : = ASSIGN* "+"); 
when TOKEN_MINUS => 

TEST_TOKEN := ASSIGN*"-"); 
when TOKEN_AMPERSAND => 

TEST_TOKEN := ASSIGN* "&"); 
when TOKEN_EQUALS => 

TEST_TOKEN ;= ASSIGN("="); 
when TOKEN_NOT_EQUALS => 
TEST_TOKEN := ASSIGN* "/ = ") ; 
when TOKEN_LESS_THAN => 

TEST_TOKEN := ASSIGN* "<") ; 
when TOKEN_LESS_THAN_EQUALS => 
TEST_TOKEN : = ASSIGN* "<=") ; 
when TOKEN_GREATER_THAN => 
TEST_TOKEN ;= ASSIGN(">"); 
when TOKEN_GREATER_THAN_EQUALS => 
TEST_TOKEN := ASSIGN* "> = ") ; 
when TOKEN_ASSIGNMENT => 
TEST_TOKEN ;= ASSIGN* ":=") ; 
when TOKENCOMMA => 

TEST_TOKEN ;= ASSIGN* ",") ; 
when TOKEN_SEMICOLON => 

TEST_TOKEN ;= ASSIGN*";"); 
when TOKENPERIOD => 

TEST_TOKEN := ASSIGN*"."); 
when TOKEN_LEFT_PAREN => 
TEST_TOKEN := ASSIGN* "("); 
when TOKEN_RIGHT_PAREN => 
TEST_TOKEN := ASSIGN*")"); 
when TOKEN_COLON => 

TEST_TOKEN := ASSIGN*":"); 
when TOKEN_APOSTROPHE => 

TEST_TOKEN := ASSIGN* ); 

when TOKEN_RANGE_DOTS => 
TEST_TOKEN := ASSIGN*". .") ; 
when TOKEN_ARROW => 

TESTTOKEN := ASSIGN* "=>") ; 
when TOKENBAR => 
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TEST_TOKEN := ASSIGN("| M ); 
when TOKEN_BRACKETS => 

TEST_TOKEN := ASSIGN* "<>") ; 
when TOKEN_LEFT_BRACKET => 

TEST_TOKEN := ASSIGN* "<<”) ; 
when TOKEN_RIGHT_BRACKET => 

TEST_TOKEN := ASSIGN* "»" ) ; 
when othe rs => null; 
end case; 

IS_SAME := (CURRENT_TOKEN = TEST_TOKEN); 
end if; 

if ( IS_SAME ) then 
H0LD_T0KEN := CURRENT_TOKEN ; 

TOKEN_SCANNER.CONSUME_TOKEN(SOURCE_FILE); 
end if; 

return (IS_SAME); 
end MATCH; 

procedure MATCHED_TOKEN( TOKEN : out TOKEN_SCANNER . TOKEN_RECORD_TYPE ) is 
-- pre - TOKENMATCHER has been set up and at least one call to the 
function MATCH has returned TRUE; 

-- post - TOKEN contains the token that caused the last call to MATCH 

to be TRUE. NOTE - All identifiers are converted to upper case 
by the token matcher and all reserved words are converted to lower 
case by the token matcher regardless of the format in the source 
code. All other token types are uneffected by the token matcher. 

begin 

TOKEN := H0LD_T0KEN ; 
end MATCHED_TOKEN; 

procedure CURRENT_TOKEN( TOKEN : out TOKEN_SCANNER. TOKEN_RECORD_TYPE ) is 
-- pre - TOKEN_MATCHER has been set up. 

-- post - TOKEN contains the token that is under the TOKENSCANNER ' s 
read head. 

begin 

TOKEN_SCANNER . L00K_T0KEN( S0URCE_F I LE , TOKEN ) ; 
end CURRENT_TOKEN; 

procedure NEXT_TOKEN( TOKEN : out TOKEN_SCANNER . TOKEN_RECORD_TYPE ) is 
-- pre - TOKENMATCHER has been set up. 

-- post - TOKEN contains the token that is next to be read by the 
TOKEN_SCANNERS read head. 

begin 

TOKEN_SCANNER.LOOK_AHEAD_TOKEN(SOURCE_FILE, TOKEN) ; 
end NEXT_TOKEN ; 

function LINESCHECKED return positive is 
pre - TOKENMATCHER has been set up. 

- post - returns the number of lines of code that have been checked 
by the TOKENMATCHER . 

begin 
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return ( TOKEN_$CANNER . LINES_SCANNED( SOURCE_F ILE ) ) ; 
end LINES_CHECKED; 

function VALIO_COMMENTS return natural is 
-- pre - TOKEN_MATCHER has been set up. 

-- post - returns the number of "meaningful" comments seen by the 
TOKEN_MATCHER . A "meaningful" comment is defined as a 
that contains at least one letter or digit. 

begin 

return ( TOKEN_SCANNER . COMMENT$_SCANNED( SOURCE_F I LE ) ) ; 
end VALID_COMMENTS; 

end TOKEN_MATCHER; 



comment 
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APPENDIX H 



"ADAFLOW” PROGRAM LISTING - TOKEN SCANNER 



TITLE : 


ADAFLOW 


-- 


MODULE NAME: 


PACKAGE TOKEN_SCANNER 


-- 


FILE NAME: 


TOKEN. ADS 


-- 


DATE CREATED: 


02 FEB 88 


-- 


LAST MODIFIED: 


: 26 APR 88 


-- 


AUTHOR(S) : 


LT ALBERT J. GRECCO, USN 


- 


DESCRIPTION: 


This package defines the interface to the 


-- 




token scanner module. 


-- 






with TEXT_IO; 

package TOKEN_SCANNER is 

-- maximum number of chars per line in file being parsed 
LINESIZE : constant integer := 132; 

ENDFILE : constant character ;= ASCII. sub; 

ENDLINE : constant character ;= ASCII. eot; 

-- ADA token classes 

type TOKEN_CLASS is { RESERVED_WORD , IDENTIFIER, SEPARATOR, NUMERICJ-IT, 
DELIMITER, COMMENT, CHARACTERLI T , STRING_LIT, 
UNDEF_CHAR, EOF); 

-- record to indicate where a token came from 
type SOURCE_RECORD is 
record 

FILE_NAME ; string( 1 .. LINESIZE ) := (others => ' ’); 

FILE_NAME_SIZE : natural := 0; 

LINE_NUMBER : natural; 
end record; 

record to hold the token built up by the token scanner. the LEXEME is 
-- the actual string for that particular token and LEXEME_SIZE is the 

- number of characters in the lexeme string. SOURCE indicates the 

- location in the source file where the token originated. 
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type TOKEN_RECORD_TYPE is 
record 

TOKEN_TYPE : TOKEN CLASS; 

LEXEME : stri ng( 1 . . LINESIZE ) := (others => ' ’); 

LEXEME_SIZE : natural := 0; 

SOURCE : SOURCE_RECORD ; 

end record; 



-- raising of any of the following exceptions indicates that an illegal 
-- token has been scanned into the look ahead token. In the case of an 
-- exception, procedure LOOKTOKEN is undefined, while procedure L00K_ 
-- AHEADTOKEN can provide access to the lexeme that raised one of the 
-- scanner exceptions. 

ILLEGAL_ IDENTIFIER : exception; 

ILLEGAL_NUMERIC_LIT : exception; 

I LLEGAL_STRING_LIT : exception; 

ILLEGAL_CHARACTER ; exception; 

procedure SE T_UP_TOKEN_SCANNER( PARSE_F I LE : in TEXT_I0. f i le_type ) ; 

-- pre - must be called before any other procedure in the token 
scanner module. Only one file may be set up at a time. 
PARSE_FILE must be open and rewound before token scanner 
can be set up. 

procedure RELEASE_TOKEN_SCANNER( PARSE_FILE : in out TEXT_IO . f i 1 e_type ) ; 
-- pre - TOKEN_SCANNER has been set up. 

-- post - All TOKEN_SCANNER interfaces are undefined with the exception 
of SET_UP_TOKEN_SCANNER. The TOKEN_SCANNER must be released 
prior to main program termination. PARSEFILE is closed. 



procedure LOOK_TOKEN( PARSE_FILE : in TEXT_IO . f i 1 e_type ; 

TOKEN : out TOKEN_RECORD_TYPE ) ; 

-- pre - scanner has been set up and an exception has not occurred. 
-- post - TOKEN contains the token under the read head in PARSE_FILE . 
The scanner filters out comments and separators. 



procedure L00K_AHEA0_T0KEN( PARSE_FILE : in TEXT_I0 . f i 1 e_type ; 

TOKEN : out TOKEN_RECORD_TYPE); 

-- pre - scanner has been set up. 

-- post - TOKEN contains the next token to come under the read head in 
PARSE_FILE. The scanner filters out comments and separators. 

procedure CONSUME_TOKEN{ PARSE_FILE ; in TEXT_I0. f i le_type ) ; 

-- pre - scanner has been set up. 

-- post - the read head is advanced one token in PARSE_FILE. 

The scanner filters out comments and separators. 



function LINES_SCANNED( PARSE_F I LE : in TEXT_IO . f i 1 e_type ) return positive; 
-- pre - scanner has been set up. 

-- post - returns the number of lines in PARSEFILE 

that have been scanned by the token scanner. 
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function COMMENTS_SCANNED{ PARSE_FI LE : in TEXT_I0 . f i 1 e_ 
-- pre - scanner has been set up. 

-- post - returns the number of "meaningful" comments i 
that have been scanned by the token scanner, 
comment is defined as a comment that contains 
1 etter or digit. 

end TOKEN_SCANNER; 



type) return natural ; 

n PARSE_FILE 
A "meaningful" 
at least one 
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TITLE: 



ADAFLOW 



-- MODULE NAME: 
-- FILE NAME: 



PACKAGE TOKEN_SCANNER 
TOKEN. ADB 



-- DATE CREATED: 02 FEB 

-- LAST MODIFIED: 26 APR 



-- AUTHOR(S): 



LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package contains the procedures which 

implement the TOKEN_SCANNER . 



with TEX T_1 0 ; 

package body TOKENSCANNER is 

CURRENT_TOKEN : TOKEN_RECORD_TYPE ; 
NEXT_TOKEN : TOKEN_RECORD_TYPE ; 
LI NE_TOTAL : positive := 1; 
COMMENT TOTAL : natural := 0; 



package BUILD_TOKEN_PIPE is 

procedure INITIALIZE_TOKEN_PIPE ; 

procedure GET_TOKEN( TEXT_FILE : in TEXT_IO.f ile_type; 

TOKEN : out TOKENRECORDTYPE ; 
IS_VALID : out boolean); 

end BUI LD_TOKEN_PI PE ; 

package body BUILD_TOKEN_PIPE is 



subtype 


UPPER_CASE_LE ITER 


i s 


character 


range 


’A’ . . ’Z’ ; 


subtype 


LOWE R_CASE_LET TER 


i s 


character 


range 


'a' . . ' z' ; 


subtype 


UPPER_CASE_HEX 


is 


character 


range 


'A' . . ' F ' ; 


subtype 


LOWER_CASE_HEX 


is 


character 


range 


' a ' . . * f * ; 


subtype 


DIGITS_TYPE 


i s 


character 


range 


’O’ . . ’9* ; 


subtype 


FORMAT_EFFECTOR 


is 


character 


range 


ASCII .HT. 


subtype 


CHAR_LIT_TYPE 


is 


character 


range 


’ 



type LOOK_UP_TABLE 
type STRING_MATRIX 



.ASCII .CR; 



is array ( LOWERCASELETTER ) of natural; 
is array (positive range 1..63) of string(1..9) 



RESERVED_WORD_MATRI X : STRINGMATRI X := 

(("abort "),("abs "), ("accept "), ("access "), 

("all " ) , ( " a n d "), ("array "),("at "), 

("begin "),("body ”),("case "),( "constant ”), 
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( "declare 


" ) , ( "del ay 


" ) , ( "del ta 


"), ("digits "). 


( "do 


" ) , ( "el se 


" ) , ( "el sif 


" ) , ( "end "), 


( "entry 


"),( "exception" ),( "ex it 


” ) , ( "f or "). 


( "function 


” ) , ( "generic 


") .("goto 


").("if "). 


( "in 


").("< s 


" ) , ( "1 imi ted 


" ) , ( " 1 oop "), 


( "mod 


" ) , ( "new 


" ) , ( "not 


" ) , ( "nul 1 "), 


("of 


" ) » ( "or 


" ) , ( "others 


"),("out "), 


("package 


"), ("pragma 


" ) , ( "private 


" ) , ( "procedure" ) , 


( " raise 


") .("range 


"),(" record 


" ) . ( " rem " ) , 


( " renames 


" ) , ( "return 


" ) , ( " reverse 


"), ("select "), 


( "separate 


" ) , ( "subtype 


" ) , ( "task 


" ) , ( "terminate" ) , 


( "then 


" ) , ( " type 


" ) , ( "use 


" ) , ( "when " ) , 


( "while 


" ) , ( "with 


" ) . ( "xor 


")); 


RESERVED_WORD 


_HASH : LOOK_ 


UP_TABLE := 




((1), (9), (11), (13), (18), 


(24) , (26) , (0) , 


( 28 ) , ( 0 ) , ( 0 ) , ( 31 ) , ( 33 ) 


(34), (37), (41), (0), (45), 


(52), (55). (59) 


,(0),(60),(63),(0),(0) 


CH : 


character := 


• ' ; 




CH_HOLD : 


character := 


' ' ; 




INI TIAL_TOKEN 


: boolean := 


TRUE; 




PARTIAL_TOKEN 


: boolean := 


FALSE; 




TOKEN_WAITING 


: boolean := 


FALSE; 





TOKEN_HOLD : TOKEN_RECORD_TYPE ; 
package GET_CHAR_PIPE is 

procedure GET_CHARACTER( TEXT_FILE : in TEXTIO.f ile_type; 

CH : out character); 

end GET_CHAR_PIPE ; 



package body GET_CHAR_PIPE is 

procedure GET_CHARACTER( TEXTFILE ; in TEXT_IO . f i 1 e^type ; 

CH : out character) is 

begin 

if TEXT_IO.END_OF_FILE(TEXT_FILE) then 
CH := ENDFILE; 

elsif TEXT_IO . ENO_OF_LINE( TEXT_FILE ) then 
TEXT_IO . SKI PLINE ( TEXT FILE); 

CH := ENDLINE; 
el se 

TEXT_IO.get( TEX T F I L E , CH); 

end if; 

end GETCHARACTER; 
end GET_CHAR_PIPE ; 



procedure INITIALIZE^TOKEN^PIPE is 
begin 

CH ; 

CHHOLD := ’ ’; 

INITI AL_TOKEN := TRUE; 

PARTI ALTOKEN := FALSE; 
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TOKEN_WA I TING := FALSE; 
end INITIALIZETOKENPIPE; 



procedure GET_TOKEN( TEXTFILE : in TEXTIO. f ile_type; 

TOKEN : out TOKEN_RECORD_TYPE ; 

IS_VALID ; out boolean) is 
LEXEME_COUNT : positive := 1; 

STATE : positive := 1; 

TEST_LEXEME : string( 1 . . LINESIZE ) ; 

SHARPREPLACEMENT ; boolean := FALSE; 

QUOTE_RE PLACEMENT : boolean := FALSE; 

function IS_RESERVED( TEST_LEXEME : in string) return boolean is 
LEXEME : string(1..9) := (others -> ' '); 

IS_MATCH : boolean := FALSE; 

ROW ; natural ; 

INDEXCHAR : character; 

HASH_STOP : natural; 

begin 

if (TEST_LEXEME' LENGTH <= 9) then 

LEXEME ( TEST_LEXEME ' RANGE ) ;= TEST_LEXEME ; 
for I in TEST_LEXEME’ RANGE loop 

if ((LEXEME(I) in DIGI TS_TYPE ) or else (LEXEME(I) = '_')) then 
return (FALSE); 

elsif ( LEXEME ( I ) in UPPER_CASE_LETTER) then 
LEXEME(I) := 

LOWER_CASE_LETTER'VAL(UPPER_CASE_LETTER'POS(LEXEME(I)) + 32); 
end if; 
end loop; 

case (LEXEME(l)) is 

when 'h' | ' j' | ’ k ' | ’q’ | 'v' | ' y ' | 'z' => 
return (FALSE); 
when others -> 

ROW := RESERVED_WORD_HASH( LEXEME( 1 ) ) ; 
if (LEXEME(l) = '*') then 
HASH_ST0P := 63; 
else 

INDEX_CHAR := character' SUCC( LEXEME ( 1 ) ) ; 
while (RESERVED_WORD_HASH(INDEX_CHAR) = 0) loop 
INDEX_CHAR := character ' SUCC( INDEX_CHAR) ; 
end loop; 

HASH_STOP := RESERVED_WORD_HASH( INDEX_CHAR) ; 
end if; 

while ((ROW <= HASHSTOP) and then (not IS_MATCH)) loop 
IS_MATCH := (LEXEME = RESERVED_WORD_MATRIX( ROW) ) ; 

ROW := ROW + 1; 
end loop; 

return (ISMATCH); 
end case; 
else 

return (FALSE); 
end if; 
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end IS_RESERVED; 
begin 

TOKEN. LEXEME := (others => ' '); 

TOKEN. SOURCE ,FILE_NAME := (others = > ' '); 
if ( INITIAL_TOKEN ) then 

GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 

INITIAL_TOKEN := FALSE; 
end if; 

if ((CH /= ENDFILE) and then (not T0KEN_WAITING ) and then 
(not PARTIAL_TOKEN ) ) then 
CH := CH_H0LD; 

GET_CHAR_PI PE . GET_CHARACTER( TEXT_FILE , CH_HOLD); 
elsif ( PARTIAL_TOKEN ) then 
PARTIAL_TOKEN := FALSE; 
end if; 

if TOKEN_WAITING then 
TOKEN := TOKEN_HOLD ; 

IS_VALID := TRUE; 

T0KEN_WAITING := FALSE; 

elsif ((CH in UPPER_CASE_LETTER ) or else (CH in LOWER_CASE_LETTER ) ) then 
TOKEN. TOKENTYPE ;= IDENTIFIER; 

TOKEN. SOURCE. LINE_NUMBER := LINE_TOTAL ; 

TOKEN. SOURCE. FILE_NAME_SIZE ;= TEXT_IO.name(TEXT_FILE) 'LENGTH; 

TOKEN. SOURCE. F I LE_NAME( 1. . TEXT_IO . name( TEXT_F ILE ) 'LENGTH) := 

TEXT_IO. name( TEXT_FILE ) ; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH ; 

TEST_LEXEME(LEXEME_COUNT) := CH; 
loop 

case STATE is 

when 1 => if ((CHHOLD in UPPER_CASE_LETTER ) or else 
(CH_HOLD in LOWER_CASE_LETTER ) or else 
(CH_HOLD in DIGI TS_TYPE ) ) then 
LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CH_HOLD; 
TEST_LEXEME(LEXEME_COUNT) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif (CH_HOLD = ) then 

STATE := 2; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH_HOLD; 

TEST_LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 

GET_CHAR_PIPE . GET_CHARACTER( TEXT_FILE , CH_HOLD ) ; 
else 

if ( IS_RESERVED( TEST_LEXEME( 1 . . LEXEME_COUNT ) ) ) then 
TOKEN. TOKEN_TYPE := RESERVED_WORD ; 
end if; 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

IS_VALID := TRUE; 
exit; 
end if; 

when 2 => if ((CHHOLD in UPPERCASELETTER) or else 
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(CH_HOLD in LOWER_CASE_LETTER ) or else 
(CH_HOLD in DIGI TS_TYPE ) ) then 
STATE := 1; 

LEXEME_COUNT := L£XEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CHHOLD; 

TEST_LEXEME( LEXEME_COUNT ) := CH_HOLD; 

GET_CHAR_PIPE . GET_CHARACTER( TEXT_FILE , CH_HOLD ) ; 
el se 

IS_VALID := FALSE; 

TOKEN. L£XEME_SIZE ;= LEXEME_COUNT ; 
exit; 
end if; 

when others => null; 
end case; 
end loop; 

elsif ( (CH in FORMAT_EFF ECTOR ) or else 

(CH = ' *) or else (CH = ENDLINE)) then 
TOKEN. TOKEN_TYPE := SEPARATOR; 

TOKEN. SOURCE. LINE_NUMBER := LINE_TOTAL; 

TOKEN. SOURCE. FILE_NAME_SIZE : = TEXT_IO . name( TEXT_FI LE ) ' LENGTH ; 

TOKEN. SOURCE. F I LE_NAM£( 1. . TEXT_IO . name( TEXT_F I LE) ’LENGTH) := 

TEXT_IO . name( TEXT_FILE); 

TOKEN. LEXEME(LEXEME_COUNT) := CH; 
if (CH = ENDLINE) then 

LINE_TOTAL := LINE_TOTAL + 1; 
end if; 

-- go ahead and flush out the rest of the separators as they will be 
-- discarded anyway 

while ( (CH_H0LD in FORMAT_EFF ECTOR ) or else (CH HOLD = ’ ' ) or else 
(CH_HOLD = ENDLINE)) loop 

LEXEME_COUNT ;= LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD; 
if (CH_H0LD = ENDLINE) then 
LI NE_TOTAL : = LINE_TOTAL + 1; 
end if; 

GET_CHAR_PI PE . GET_CHARACTER( TEXT_F ILE , CH_HOLD) ; 
end loop; 

TOKEN. LEXEME_SIZE := LEXEMECOUNT; 

IS_VALID := TRUE; 
elsif (CH in DIGI TS_TYPE ) then 
TOKEN. TOKEN_TYPE := NUMERIC_LIT; 

TOKEN. SOURCE. LINENUMBER := LINETOTAL; 

TOKEN. SOURCE. F I LE _NAME_SIZE := TEXT_IO . name( TEXT_FI LE )' LENGTH ; 

TOKEN. SOURCE. FILE_NAME( 1. . TEXT_IO . name( TEXT_FI LE ) ’ LENGTH ) := 

TEXT_IO. name (TEXT_F ILE) ; 

TOKEN. LEX EM E( LEXEME_COUNT ) ;= CH; 
loop 

case STATE is 

when 1 => if (CH_HOLD in DIGITS_TYPE ) then 

LEXEMECOUNT := LEXEMECOUNT + 1; 

TOKEN. LEXEME( LEXEMECOUNT ) CHHOLD; 
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GE T_CHAR_P I PE . GET_CHARACTER( TEXT_FILE , CH_HOLD ) ; 
el si f (CHHOLD = ’ . ' ) then 
STATE := 2; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH_HOLD; 

GET_CHAR_PI PE . GET_CHARACTER( TEXT_F I LE , CH_HOLD); 
elsif ( (CH_HOLD = * E * ) or else (CH_HOLD = ’e')) then 
STATE := 17; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TO KEN. LEXEME { LEXEME_COUNT ) := CH_HOLD ; 

GET_CHAR_PI PE . GET_CHARACTER( TEXT_FILE , CH_HOLD) ; 
elsif (CH_HOLD = ) then 

STATE ;= 9; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME{ LEX£ME_COUNT ) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif ( (CH_HOLD = '#') or else (CH_HOLD = then 

SHARP_RE PLACEMENT := (CH_HOLD = 

STATE : = 10; 

LEXEM£_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif ( (CH_HOLD in UPPER_CASE_LETTER ) or else ( CH_HOLD in 
LOWER_CASE_LETTER) ) then --must be a separator 
--between a numeric literal and an identifier. 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

IS_VALID := FALSE; 
exit; 
else 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

ISJ/ALID := TRUE; 
exit; 
end if; 

when 2 => if (CH_HOLD in DIGI TS_TYPE ) then 
STATE := 3; 

LEXEME_COUNT := LEX£ME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CHHOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif {CHHOLD = then --test for range dots 

TOKEN . LEXEME( LEXEME_COUNT ) := • '; 

TOKEN. LEXEME_SIZE := LEXEMECOUNT - 1; 

ISJ/ALID ;= TRUE; 

TOKEN_HOLD . TOKEN_TYPE := DELIMITER; 

TOKENHOLD. LEXEME( 1 . . 2 ) := " . . " ; 

TOKEN_HOLD . LEXEME_SI ZE := 2; 

TOKEN_HOLD . SOURCE . LINE_NUMBER := L INE_TOTAL ; 

TOKEN_HOLD. SOURCE. F I LE_NAME_SIZE := 

TEXTIO. name(TEXT_F I LE) ’LENGTH; 

TOKEN_HOLD . SOURCE . FILENAME ( 1. ,TEXT_IO. 

name( TEXTFILE)’LENGTH) := TEXTIO . name( TEXTF I LE ) ; 
GET_CHAR_PIPE.GET_CHARACTER( TEX T_F I LE , CH HOLD) ; 
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TOKEN_WAITING := TRUE; 
exit; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID FALSE; 
exit; 
end if; 

when 3 => if (CH_HOLD in DIGITS_TYPE ) then 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEX£ME_COUNT) ;= CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif ( (CH_HOLD = ' E • ) or else (CHHOLD = 'e')) then 
STATE := 4; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEX EME( LEXEME_COUNT ) := CH_HOLD; 

GET_CHAR_PIPE .GET_CHARACTER( TEX T_F I LE , CH_HOLD ) ; 
elsif (CH_HOLD = ) then 

STATE := 5; 

LEXEME_COUNT ;= LEXEME_COUNT + 1; 

TOKEN. LEXEME ( LE XEME_COUNT ) ;= CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE. CHHOLD); 
elsif ((CHHOLD in UPPERCASELETTER ) or else (CH_HOLD in 
LOWER_CASE_LETTER) ) then 
TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

ISJ/ALID := FALSE; 
exit; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := TRUE; 
exit; 
end if; 

when 4 = > if ( (CH_H0LD = '+*) or else (CH_H0LD = ’-*)) then 
STATE := 6; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN , LEXEME ( LEX EME_C0UNT ) := CH_HOLD; 

GET_CHAR_PIPE .GET_CHARACTER( TEXTFILE , CHHOLD) ; 
elsif (CH_HOLD in DIGI TS_TYPE ) then 
STATE := 7; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEX EME( LEXEME_COUNT ) := CH_HOLD ; 

GET_CHAR_PIPE . GET_CHARACTER( TEXT_FILE , CH_HOLD ) ; 
else 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

I SVAL ID := FALSE; 
exit; 
end if; 

when S | 6 1 8 1 9 => if ( CH_HOLD in DIGITS_TYPE ) then 
case STATE is 

when 5 => STATE := 3; 

when 6 1 8 => STATE := 7; 
when 9 => STATE := 1; 
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when others => null; 
end case; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEX EME_C0UNT ) ;= CH_H0L0; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_H0LD) ; 
el se 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALI0 := FALSE; 
exit; 
end if; 

when 7 => if (CH_H0LD in DIGITS_TYPE) then 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CH_H0LD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_H0LD) ; 
elsif (CH_H0LD = ) then 

STATE ;= 8; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEX EME_C0UNT ) := CHHOLD; 

GETCHARPI PE .GET_CHARACTER( TEXT_FILE , CH_H0LD ) ; 
elsif ( (CH_HOLD in UPPER_CASE_LETTER ) or else ( CH_HOLD in 
LOWER_CASE_LETTER ) ) then 
TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

I S_VALID := FALSE; 
exit ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

ISJ/ALID := TRUE; 
exit; 
end if; 

when 10 => if ( (CHHOLD in DIGI TSTYPE ) or else 
(CH_H0LD in UPPERCASE _HEX ) or else 
(CH_H0LD in LOWER_CASE_HEX ) ) then 
STATE := 11; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME( LEXEME_COUNT ) := CH_H0L0; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_H0LD) ; 
elsif ( ( CH HOLD = ' = ') and then ( SHARP_REPLACEMENT ) ) then 
SH A RP_RE PLACEMENT := FALSE; 

TOKEN. LEXEME(LEXEME_COUNT) 

TOKEN. LEXEME_SIZE := LEXEME_COUNT - 1; 

IS_VALID := TRUE; 

TOKENHOLD.TOKENTYPE := DELIMITER; 

TOKENHOLO . LEXEME ( 1 . . 2 ) := 

TOKEN_HOLD.LEXEME_SIZE := 2; 

T0KEN_H0LD . SOURCE . LI NE_NUMBER := LINE_TOTAL ; 

TOKENHOLO . SOURCE . FILENAMESI ZE := 

TEXT 10. name(TEXT_FILE )' LENGTH; 

TOKEN HOLD. SOURCE . FILE_NAME( 1 . .TEXT_I0. 

name( TEXTFILE)' LENGTH) := TEXT_IO.name(TEXT_FILE) ; 
GETCHAR PIPE .GET_CHARACTER( TEXTFILE, CH_HOLD) ; 

TOKEN WAITING := TRUE; 
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exit; 



else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
end if; 

When 11 => if ( (CH_HOLD in DIGITS_TYPE) or else 
(CH_HOLD in UPPER_CASE_HE X ) or else 
(CH_HOLD in LOWER J]ASE_HEX ) ) then 
LEXEME_COUNT ;= LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 

GET_CHAR_PIPE .GET_CHARACTER( TEXTFILE , CH_HOLO) ; 
elsif (CH_HOLD = then 

STATE := 14; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 

GET_CHAR_PIPE .GET_CHARACTER( TEXT_FILE . CH_HOLO) ; 
elsif (CHHOLD = ) then 

STATE := 12; 

LEXEME_COUNT := LEXEME_COUNT +■ 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLO) ; 
elsif ( ( (CH_H0LD = '#') and (not SHARP_REPLACEMENT ) ) or 
else ((CHHOLD = and SHARP_RE PLACEMENT ) ) then 

STATE := 13; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEX EME_COUNT ) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

ISJ/ALID := FALSE; 
exit; 
end if; 

when 12 | 14 | 16 => if ( (CHJHOLD in DIGI TS_TYPE ) or else 
(CH_HOLD in UPPER_CASE_HEX ) or else 
(CH_HOLD in LOWER_CASE_HEX ) ) then 
case STATE is 

when 12 => STATE := 11; 

when 14 1 16 => STATE := 15; 
when others => null; 
end case; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_F ILE , CH_HOLD) ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
end if; 

when 13 => if ((CHHOLD = 'E') or else ( CH_HOLD = ’e’)) then 
STATE := 17; 
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LEXEME_COUNT := LEXEMECOUNT + i; 

TOKEN . LEXEME ( LEXEME_COUNT) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
elsif ( (CH_HOLD in UPPER_CASE_LETTER) or else ( CH_HOLD 
LOWER_CASE_LETTER ) ) then 
TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
else 

TOKEN. LEXEME_SIZE ;= LEXEME_COUNT ; 

IS_VALI0 := TRUE; 
exit; 
end if; 

when 15 => if ( (CH_H0LD in OIGITS_TYPE) or else 
(CH_HOLD in UPPERCASE JiEX ) or else 
(CH_HOLD in LOWER_CASE_HEX ) ) then 
LEXEHE_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXE ME ( LEXEME_COUNT ) ;= CH_H0LD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CHHOLD ) ; 
elsif (CFI_H0LD = then 

STATE := 16; 

LEXEME_COUNT := LEXEME_C0UNT + 1; 

TOKEN . LEXEME( LEXEMECOUNT ) CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLO); 
elsif ( ( ( CH_H0L0 = '#’) and (not SHARP_REPLACEMENT ) ) or 
else ((CH_HOLD = and SHARP_RE PLACEMENT ) ) then 

STATE := 18; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXE ME ( LEXEME_COUNT) := CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
el se 

TOKEN. LEXEMESIZE := LEXEME_COUNT ; 

IS_VALI0 := FALSE; 
exit; 
end if; 

when 17 => if ( CH_HOLD = '+') then 
STATE := 6; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CH_H0L0; 

GET_CHAR_PI PE .GET_CHARACTER( TEXT_FILE , CH_HOLD) ; 
elsif (CH_HOLD in DIGI TS_TYPE ) then 
STATE ;= 7; 

LEXEME_COUNT := LEXEMECOUNT + 1; 

TOKEN. LEXE ME ( LEXEME_COUNT ) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

I S_VAL ID := FALSE; 
exit; 
end if; 

when 18 -> if ( ( CH_HOLD - ’ E ’ ) or else ( CH_HOLD = ’ e ’ ) ) then 
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STATE := 4; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CHHOLD; 

GET_CHAR_PIPE . GET_CHARACTER( TEXTFI LE , CH_HOLD ) ; 
elsif ( (CH_HOLD in UPPER_CASE_LETTER ) or else (CH_HOLD in 
LOWER_CASE_LETTER) ) then 
TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

ISJ/ALID := TRUE; 
exit; 
end if; 

when others => nul 1 ; 
end case; 
end loop; 

elsif (CH = ' ' ' ) then 

TOKEN. SOURCE. LINE_NUMBER := L INE_T0TAL ; 

TOKEN. SOURCE. FILE_NAME_SIZE := TEXT_IO.name(TEXT_FILE) 'LENGTH; 

TOKEN. SOURCE. FILE_NAME( 1 . . TEXT_IO . name( TEXT_F I LE )' LENGTH ) := 

TEXT_IO . name( TEXTFILE); 

TOKEN . LEXEME { LEXEME_COUNT ) CH ; 

ISJ/ALID TRUE; 
loop 

case STATE is 

when 1 => if (CHHOLD in CHAR_LIT_TYPE ) then 
STATE ;= 2; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME (LEXEME_COUNT) := CH_HOLD ; 

CH := CH_HOLD; 

GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
else 

TOKEN. TOKEN_TYPE := DELIMITER; 

TOKEN. LEXEME_SIZE ;= LEXEME_COUNT ; 
exit; 
end if; 

when 2 => if (CH_HOLD = * ' * ) then 

TOKEN. TOKEN_TYPE := CHARACTER_LIT ; 

LEXEMECOUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME (LEXEME_COUNT) ;= CHHOLD; 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
exit; 
else 

TOKEN. TOKEN_TYPE := DELIMITER; 

PARTI AL_TOKEN := TRUE; 

TOKEN . LEXEME( LEXEMECOUNT) ; 

TOKEN. LEXEME_SIZE := LEXEME_COUNT - 1; 
exit; 
end if; 
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when others => null ; 



end case; 



end loop; 



elsif ( ( CH - '&’) or else (CH * '(') or else (CH = ')') or else 
(CH = '•') or else (CH = ’+') or else (CH = or else 

(CH = or else (CH = or else (CH = '/') or else 

(CH = or else (CH = ';') or else (CH = '<') or else 

(CH = •=') or else (CH = ’>•) or else (CH = ' | ' ) or else (CH = '!')) then 

TOKEN. TOKEN_TYPE := DELIMITER; 

TOKEN. SOURCE. LINE_NUMBER := LlNE_TOTAL ; 

TOKEN. SOURCE. FILE_NAME_SIZE := TEXT_IO. name( TEX T_F I LE ) ’ LENGTH; 

TOKEN. SOURCE. FILENAME ( 1. . TEXT_IO. name( TEXT_FILE) ' LENGTH) : = 



TEXT_IO. name( TEXT_FILE); 

IS_VALID := TRUE; 

TOKEN. LEXEME(LEXEME_COUNT) := CH; 
case CH_H0LD is 

when => if (CH = '.’) then 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) ;= CH_HOLD; 
GET_CHAR_PIPE . GET_CHARACTER( TEXT_FILE, CH_HOLD) ; 
end if; 

when '•* = > if (CH = '*') then 

LEXEME_COUNT ;= LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD; 
GET_CHAR_PIPE . GET_CHARACTER( TEXT_FILE , CH_HOLD) ; 
end if; 



when '=' 



when ' > 1 



when '<' 



when ' - ' 



=> if ((CH = or else (CH = '/') or else (CH = ’>') or 

else (CH = ' < ' ) ) then 

LEXEME_COUNT ;= LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
end if; 

=> if ((CH = '<’) or else (CH = ’>') or 
else (CH = ' = ' )) then 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXE ME ( LEXEME_COUNT ) := CH_HOLD ; 

GETCHARPIPE . GET_CHARACTER( TEXT_FILE , CH_HOLD) ; 
end if; 

=> if (CH - ’<' ) then 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXE ME ( LEXEME_COUNT ) := CHHOLD; 

GET_CHAR_PIPE .GET_CHARACTER( TEXT _F I L E , CH_HOLD) ; 
end if; 

=> if (CH = • ) then 

TOKEN. TOKENTYPE := COMMENT; 

LEXEME COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME_COUNT) := CH_HOLD ; 

GETCHARPI PE . GET_CHARACTER( TEXT F ILE , CH_HOLD) ; 
while ( ( CH_HOLD /= ENDLINE) and 
(CH HOLD /= ENDFILE)) loop 

LEXEME COUNT LEXEME COUNT +■ 1; 
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TOKEN . LEXEME ( LEX EMECOUNT ) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
end loop; 
end if; 

when others => null; 
end case; 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 
elsif ( ( CH = or else (CH = '%')) then 

TOKEN. TOKEN_TYPE := STRING_LIT ; 

TOKEN. SOURCE. LINE_NUM8ER := LINE_TOTAL; 

TOKEN. SOURCE. F I LE_NAME_SIZE := TEXT_I0 . name( TEXT_F I LE ) * LENGTH ; 

TOKEN. SOURCE. FILE_NAME( 1. . TEXT_IO . name( TEXT_FI LE ) 'LENGTH) := 

TEXTIO . name{ TEXTFILE ) ; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH; 

QUOTERE PLACEMENT := (CH = 
loop 

case STATE is 

when 1 => if (((CHHOLD = and (not QUOTE_RE PLACE MEN T ) ) or else 

((CHHOLD = '%') and QUOTE_REPLACEMENT ) ) then 
STATE := 2; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEX EMECOUNT ) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
elsif (CH_HOLD in CHAR_LI T_TYPE ) then 

if ( (QUOTE_REPLACEMENT and ( CH_HOLD /= ’%*)) or else 
( (not(QUOTE_REPLACEMENT) ) and (CH_HOLD /= '"'))) then 
STATE := 4; 

LEXEMECOUNT := LEXEMECOUNT + 1; 

TOKEN . LEXEME ( LEX EME_COUNT ) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD ) ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
end if; 
else 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

I S_VALID := FALSE; 
exit; 
end if; 

when 2 => if ( ( (CH_HOLD = '"•) and (not QUOTERE PLACEMENT ) ) or else 
( ( CH_HOLD = ’%’) and QUOTE_REPLACEMENT) ) then 
STATE := 3; 

LEXEME_COUNT := LEXEMECOUNT + 1; 

TOKEN . LEXEME ( LEXEMECOUNT ) := CH_HOLD; 

GET_CHAR_PI PE ,GET_CHARACTER( TEXT_F I LE , CH_HOLD) ; 
else 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

IS_VALID := TRUE; 
exi t; 
end if; 



239 



when 3 => if ( ( (CH_HOLD = ) and (not QUO TE_RE PLACEMENT ) ) or else 

((CH_H0LD = '%') and QUOTE_RE PLACEMENT ) ) then 
LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

GET_CHAR_PIPE . GET_CHARACTER{ TEXT_FI LE , CHHOLD) ; 
exit; 

elsif (CH_HOLD in CHAR_LIT_TYPE ) then 

if ( (QUOTE_RE PLACEMENT and (CH_HOLD /= '%')) or else 
( ( no t(QUOTE_RE PLACEMENT) ) and ( CH_HOLD /= '"'))) then 
STATE := 4; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN . LEXEME ( LEXEME_COUNT ) := CH_HOLD ; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CHHOLD) ; 
else 

TOKEN. LEXEME_SIZE : = LEXEME_COUNT ; 

I S_VALID := FALSE; 
exit; 
end if; 
else 

TOKEN. LEXEME_SIZE ;= LEXEME_COUNT ; 

IS_VALID := FALSE; 
exit; 
end if; 

when 4 => if ( ( (CH_HOLD = and (not QUOTE RE PLACEMENT ) ) or else 

( ( CH_HOLD = ’%') and QUOTE ^REPLACEMENT ) ) then 
STATE := 2; 

LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN LEXEME(LEXEME_COUNT) ;= CH_HOLD; 

GET_CHAR_P IPE . GET_CHARACTER( TEXT_F I LE , CH_HOLD) ; 
elsif (CH_HOLD in CHAR_LIT_TYPE ) then 

if ( ( QUO TE_RE PLACEMENT and ( CH_HOLD /= '%')) or else 
( ( not (QUOTE RE PLACEMENT) ) and (CH_HOLD /= ’ " * ) ) ) then 
LEXEME_COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH_HOLD; 

GET_CHAR_PIPE . GET_CHARACTER( TEXTF I LE , CHHOLD); 
else 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

I S_VALI D := FALSE; 
exit; 
end if; 
else 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

IS_VALID ;= FALSE; 
exit; 
end if; 

when others => null; 
end case; 
end loop; 

elsif (CH - ENDFILE) then 
TOKEN. TOKEN TYPE := EOF; 
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TOKEN . SOURCE . LINE_NUMBER := LINE_TOTAL; 

TOKEN. SOURCE. FI LE_NAME_SI ZE := TEXT_IO . name( TEX T_F I LE )’ LENGTH ; 

TOKEN. SOURCE. F I LE_NAME( 1 .. TEXT_IO . name( TEXT_F I LE )' LENGTH ) := 

TEXT_IO . name( TEXT_F ILE ) ; 

TOKEN. LEXEME ( LEXEME COUNT ) ; = CH; 

TOKEN. LEXEME_SIZE := LEXEMECOUNT ; 

ISJ/ALID := TRUE; 

else -- character is not defined in ADA 
TOKEN. TOKEN_TYPE := UNDEFCHAR; 

TOKEN. SOURCE. LINEJ1UMBER := LINE_TOTAL ; 

TOKEN. SOURCE. FILE_NAME_SIZE := TEXT_IO . name( TEX T_F ILE )' LENGTH ; 

TOKEN. SOURCE. FI LE_NAME( 1. .TEXT_IO. name(TEXT_F ILE) 'LENGTH) := 

TEX T_IO. name ( TEXT F ILE) ; 

TOKEN. LEXEME ( LEXEME_COUNT ) := CH; 

TOKEN. LEXEME_SIZE := LEXEME_COUNT ; 

ISJ/ALID := FALSE; 
end if; 

end GET_TOKEN ; 
end BUILD_TOKEN_PIPE; 

function VALID_COMMENT( TOKEN : in TOKEN_RECORD_TYPE ) return boolean is 
-- pre - TOKEN is a comment. 

-- post - if the lexeme of the comment contains at least one letter or 
digit then VALID_COMMENT is true, else VALID_COMMENT is false, 
subtype UPPER_CASE_LETTER is character range ' A ’ . . ' Z * ; 

subtype LOWER_CASE_LETTER is character range 'a '..'z'; 

subtype DIGITS_TYPE is character range '0'..'9'; 

I S_VAL ID : boolean := FALSE; 

LEXEME_COUNT : positive := 3; 
begin 

while ((not IS_VALID) and ( LEXEME_COUNT <= TOKEN . LEXEME_SIZE ) ) loop 

ISJ/ALID := ((TOKEN. LEXEME ( LEXEME_COUNT ) in UPPER_CASE_LETTER ) or else 
(TOKEN. LEXEME(LEXEME_COUNT) in LOWER_CASE_LETTER ) or else 
(TOKEN. LEXEME(LEXEME_COUNT) in DIGI TS_TYPE ) ) ; 

LEXEME_COUNT ;= LEXEME_COUNT + 1; 
end loop; 
return ISJ/ALID; 
end VAL I D ^COMMENT ; 

procedure SET_UP_TOKEN_SCANNER( PARSE_FILE ; in TEXT_IO. f ile_type) is 
-- pre - must be called before any other procedure in the TOKEN_ 

SCANNER module, only one file may be set up at a time. 
PARSE_FILE must be open and rewound before TOKENSCANNER 
can be set up. 

ISJ/ALID : boolean; 
begin 

LINE JTOTAL ;= 1; 

COMMENT JTOTAL := 0; 

BUI LD_TOKEN_PI PE .INI TI ALI ZE_TOKEN_PI PE ; 

BUI LD_TOKEN_PIPE . GET_TOKEN( PARSE_F ILE , NEXTTOKEN, IS_VALI0); 
while ( I S J/AL 1 0 and ((NEXT TOKEN. TOKEN_TYPE = SEPARATOR) or else 



241 



(NEXT_TOKEN. TOKEN_TYPE = COMMENT))) loop 
if (NEXT_TOKEN.TOKEN_TYPE = COMMENT) then 
if ( VALID_COMMENT (NEXT_TOKEN ) ) then 
COMMENT_TOTAL := COMMENTTOTAL + 1; 
end if; 
end if; 

BUILD_TOKEN_PIPE.GET_TOKEN(PARSE_FILE, NEXT_TOKEN, IS_VALID); 
end loop; 



if ( IS_VALID) then 

CONSUME_TOKEN( PARSE_FILE ) ; 
else 

case (NEXT_TOKEN.TOKEN_TYPE ) 
when IDENTIFIER => raise 

when NUMERIC_LIT => raise 

when STRING_LIT -> raise 

when UNDEF_CHAR => raise 

when others => null; 



is 

ILLEGAL_IDENTI FIER; 

ILLEGAL_NUMERIC_LIT; 

ILLEGAL_STRING_LIT; 

I LLEGAL_CHARACTER ; 



end case; 



end if; 

end SET_UP_TOKEN_SCANNER; 



procedure RELEASE_TOKEN_SCANNER( PARSE_F ILE : in out TEXT_IO. f i le_type) is 
-- pre - TOKENSCANNER has been set up. 

-- post - All TOKEN_SCANNER interfaces are undefined with the exception of 

SET_UP_TOKEN_SCANNER . The TOKEN_SCANNER must be released prior to 
main program termination. PARSEFILE is closed. 

begin 

TEXT_IO.close( PARSE_FILE ) ; 
end RELEASE_TOKEN_SCANNER; 



procedure LOOK_TOKEN( PARSE_FILE : in TEXT_IO . f i 1 e_type ; 

TOKEN : out TOKEN_RECORD_TYPE ) is 

-- pre - scanner has been set up and an exception has not occurred. 
-- post - TOKEN contains the token under the read head in PARSEFILE. 
The scanner filters out comments and separators. 

begin 

TOKEN := CURRENTTOKEN; 
end LOOK_TOKEN; 



procedure LOOK_AHEAD_TOKEN( PARSE_FILE : in TEXT_IO. f i le_type; 

TOKEN : out TOKEN_RECORD_TYPE ) is 

post - TOKEN contains the next token to come under the read head in 
PARSEFILE. The scanner filters out comments and separators. 

begin 

TOKEN := NEXT_TOKEN ; 
end LOOKAHEAOTOKEN; 



procedure CONSUME_TOKEN( PARSEFILE : in TEXT_IO. f i le_type ) is 
-- pre - the scanner has been set up. 

post - the read head is advanced one token in PARSEFILE. 
The scanner filters out comments and separators. 
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I S_VAL I D : boolean; 

TEMP_TOKEN : TOKEN_RECORD_TYPE ; 
begin 

CURR£NT_TOKEN := NEXT_TOKEN ; 
if (NEXT_TOKEN.TOKEN_TYPE /= EOF) then 

BUILD_TOKEN_PIPE . GET_T0KEN( PARSE _F ILE , TEMP_TOKEN , IS_VALID); 
while (ISJ/ALID and ( ( TEMPTOKEN . TOKEN_TYPE = SEPARATOR) or else 
( TEMP_TOKEN . TOKEN_TYPE = COMMENT))) loop 
if (TEMP_TOKEN . TOKEN_TYPE = COMMENT) then 
if (VALID_COMMENT( TEMP_TOKEN ) ) then 
COMMENT_TOTAL := COMMEN T_TOTAL + 1; 
end if; 
end if; 



BUILD_T0KEN_PIPE.GET_T0KEN(PARSE_FILE, TEMP_TOKEN , IS_VALID); 
end loop; 

if ( not( IS_VALI0) ) then 

case (NEXT_TOKEN.TOKEN_TYPE) is 

when IDENTIFIER => raise ILLEGAL_IDENTIFIER ; 

when NUMERIC_LIT => raise ILLEGAL_NUMERIC_LI T ; 

when STRING_LIT => raise ILLEGAL_STRING_LIT ; 

when UNDE F_CHAR => raise ILLEGAL_CHARACTER; 

when others => null; 

end case; 
else 

NEXT_TOKEN := TEMP_TOKEN ; 
end if; 
end if; 

end CONSUME_TOKEN ; 



function LINES_SCANNED{ PARSEFILE : in TEXT_IO.f iletype) return positive is 
-- post - returns the number of lines in PARSE_FILE 

that have been scanned by the token scanner. 

begin 

return CURRENT_TOKEN . SOURCE . LINE_NUMBER ; 
end LINES_SCANNED; 



function COMMENTS_SCANNED( PARSE_F ILE : in TEXT_IO . f i 1 e_ty pe ) 
return natural is 

-- pre - scanner has been set up. 

-- post - returns the number of "meaningful" comments in PARSE_FILE 

that have been scanned by the token scanner. A "meaningful" 
comment is defined as a comment that contains at least one 
letter or digit. 

begin 

return COMMENT_TOTAL ; 
end COMMENTSSCANNED ; 



end TOKEN_SCANNER ; 
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APPENDIX I 



"A DA FLOW” PROGRAM LISTING - GENERIC PACKAGES 



TITLE: 


ADAFLOW 


-- 


MODULE NAME: 


PACKAGE GENERIC_LIST 


-- 


FILE NAME: 


LIST. ADA 


-- 


DATE CREATED: 


31 MAR 88 


-- 


LAST MODIFIED: 


: 28 APR 88 


-- 


AUTHOR(S) : 


LT ALBERT J. GRECCO, USN 


- 


DESCRIPTION: 


This package defines the operations 
available on the abstract data type LIST. 


- 



generic 

type ITEM_TYPE is private; 
package GENERIC_LIST is 

type LIST is limited private; 

LISTJ3VERFLOW : exception; 

LIST_UNDERFLOW : exception; 

-- Operations; If the list is not empty, then one of the nodes is designated 
as the current node. Ocaasionally, in the postcondition, it is necessary 
to refer to the list of the current node as they were immediately before 
execution of the operation. L-pre and c-pre, respectively, are employed 
for these references. 

procedure FIND_FI RST ( L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

procedure FIND_NEXT(L : in out LIST); 

pre - The list L is not empty and the last node is not the current node, 
post - c-next in L is the current node, 
exceptions raised - LISTUNDERFLOW if L is empty. 

- LISTOVERFLOW if the last node is the current node. 
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procedure F IND_PREVIOUS( L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 

procedure FIND_LAST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure RETRIEVE( L : in LIST; ITEM : out I TEM_TYPE ) ; 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

procedure UPDATE ( L : in out LIST; ITEM : in ITEM_TYPE ) ; 

— pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure INSERT ( L : in out LIST; ITEM : in ITEM_TYPE ) ; 

— pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 

node in L-pre, if any, is its predecessor. The node containing 

ITEM is the current node. 

-- exceptions raised - LISTOVERFLOW if L has reached its bound. 

procedure DELETE(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LI STJJNDERFLOW if L is empty. 

function SIZE_OF(L ; in LIST) return natural; 

-- post - SIZE_0F is the number of nodes in list L. 

function EMPTY(L : in LIST) return boolean; 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 

function FULL(L : in LIST) return boolean; 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 



function FIRST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

- post - If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 
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function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure CREATE(L : in out LIST; SUCCESS : out boolean); 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

procedure DISPOSE(L : in out LIST); 

-- post - L-pre does not exist. 

private 

type LI ST_I NSTANCE ; 

type LIST is access LIST_INSTANCE ; 

end GENERIC_LI ST ; 

with UNCH EC KED_DE ALLOCATION ; 
package body GENERIC_LIST is 

type NODE ; 

type NODE_POINTER is access NODE; 
type NODE is 
record 

ELEMENT : ITEM_TYPE ; 

NEXT : NODE_POI NTER ; 
end record; 
type LIST_INSTANCE is 
record 

HEAD : NODEPOINTER := null; 

TAIL : NODE_POINTER := null; 

CURRENT : NODE_POINTER := null; 

SIZE : natural := 0; 
end record; 

procedure FREE_NODE is new UNCHECKED_DEALLOCATION( NODE , NODE_POI NTER ) ; 
procedure FREELIST is new UNCHECK ED_DEALLOCAT I ON ( LI ST_I NSTANCE , LIST); 

procedure FIND_FIRST(L : in out LIST) is 
-- pre - The list L is not empty. 

- post - The first node is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
begin 

if (EMPTY(L)) then 

raise LI STJJNDERFLOW ; 
end if; 

L. CURRENT := L . HEAD; 
end FINDFIRST; 
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no 



the current node. 



procedure FIND_NEXT(L : in out LIST) is 
-- pre - The list L is not empty and the last node is 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

- LIST_0VERFL0W if the last node is the current node. 

begin 

if ( EMPTY ( L ) ) then 

raise LISTUNDERFLOW ; 
end if; 

if ( LAST ( L ) ) then 

raise LISTOVERF LOW ; 
end if; 

L. CURRENT := L . CURRENT . NEXT ; 
end FIND_NEXT ; 

procedure F IND_PREVIOUS( L : in out LIST) is 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty or c is the first node. 

TEMPPOINTER : NODE_POINTER ; 

begin 

if ( EMPTY ( L ) or FIRST(L) ) then 
raise LISTJJNDERFLOW; 
end if; 

TEMP_POINTER := L .HEAD ; 

while ( TEMP_POINTER . NEXT /= L. CURRENT) loop 
TEMP_P0INTER := TEMP_POlNTER . NEXT ; 
end loop; 

L. CURRENT := TEMP_POINTER ; 
end FINDPREVIOUS; 

procedure FIND_LAST(L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
begin 

if (EMPTY(L)) then 
raise LISTJJNDERFLOW; 
end if; 

while (not LAST ( L ) ) loop 
F IND_NEXT( L ) ; 
end loop; 
end FINDLAST; 

procedure RETRIEVE ( L : in LIST; ITEM : out ITEM_TYPE ) is 
-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
beg in 

if (EMPTY(L)) then 

raise LIST UNDERFLOW; 
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end if; 

ITEM ;= L. CURRENT. ELEMENT; 
end RETRIEVE; 

procedure UPDATE(L : in out LIST; ITEM : in ITEMTYPE) is 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LISTUNDERFLOW if L is empty, 
beg in 

if (EMPTY(L) ) then 
raise LIST_UNOERFLOW ; 
end if; 

L. CURRENT. ELEMENT := ITEM; 
end UPDATE; 

procedure INSERT( L : in out LIST; ITEM : in ITEMTYPE) is 
-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 
node in L-pre, if any, is its predecessor. The node containing 
ITEM is the current node. 

-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 

TEMPPOINTER ; NODE_POlNTER ; 

begin 

if (FULL(L)) then 
raise LISTOVERFLOW; 
end if; 

TEMP_P0INTER := new NODE ’(ITEM, null); 
if ( L . HEAD = null ) then 
L . HEAD := TEMP_POINTER; 

L.TAIL := TEMP_POINTER ; 
else 

L.TAIL. NEXT := TEMP_POINTER ; 

L.TAIL := TEMP_POINTER; 

end if; 

L. CURRENT := TEMP_POINTER; 

L.SIZE := L . SIZE + 1; 
end INSERT; 

procedure DELETE(L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 

TEMP POINTER : NODE_POINTER ; 
beg i n 

if ( EMPTY ( L ) ) then 

raise LISTUNDERFLOW; 
end if; 

if (L. CURRENT /= L .HEAD) then 
TEMPPOINTER ;= L .HEAD; 
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while ( TEMP_POINTER .NEXT /= L. CURRENT) loop 
TEMP_POINTER := TEMP_POINTER . NEXT ; 
end loop; 

TEMPPOINTER . NEXT := L . CURRENT . NEXT ; 
if (L. CURRENT = L. TAIL ) then 
L . TAIL ;= TEMP POINTER; 
end if; 
else 

if ( L . HEAD = L.TAIL) then 
L . TAIL := null ; 
end if; 

L .HEAD := L. HEAD. NEXT; 
end if; 

FREE_NODE(L. CURRENT); 

L. CURRENT := L.TAIL; 

L . SIZE L . SIZE - 1; 
end DELETE; 



function SIZE_OF(L : in LIST) return natural is 
-- post - SIZE_0F is the number of nodes in list L. 
begin 

return (L.SIZE); 
end SIZE_OF ; 



function EMPTY(L : in LIST) return boolean is 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY 
false. 

begin 

return ( L . HEAD = null ); 
end EMPTY; 



function 
-- post - 



FULL(L : in LIST) return boolean is 

If the number of nodes in the list L has reached the maxi 
allowed, then FULL is true, else FULL is false. 



TEMP_POINTER : NODE_POINTER ; 



begin 

TEMP_POINTER := new NODE; 
FREE_N0DE ( TEMP_POINTER ) ; 
return (FALSE); 
exception 

when STORAGE_ERROR => 
return (TRUE); 
when others => 
raise ; 
end FULL; 



function 


FIRST ( L 


: i n 


LIST 


-- pre - 


The 


lis 


t L i 


s not 


-- post - 


If 


the 


first 


node 


-- 


FIRST i 


s fal 


se . 


- except 


ions 


ra i 


sed 


LIST 



) return boolean is 
empty . 

is the current node in L then FIRST 
UNDERFLOW if L is empty. 



is 



mum 



true, else 
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begin 

if (EMPTY(L)) then 
raise LIST_UNDERFLOW ; 
end if; 

return (L. CURRENT = L . HEAD) ; 
end FIRST; 

function LAST(L ; in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if ( EMPTY ( L ) ) then 

raise LISTJJNDERFLOW; 
end if; 

return (L. CURRENT = L . TAIL) ; 
end LAST; 

procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

begin 

L := new LIST_INSTANCE ’(null, null, null, 0); 

SUCCESS ;= TRUE; 
exception 

when ST0RAGE_ERR0R => 

SUCCESS := FALSE; 
when others => 
raise ; 
end CREATE; 

procedure DISP0SE(L : in out LIST) is 
-- post - L-pre does not exist, 
begin 

if (not EMPTY(L)) then 
FIND_LAST ( L) ; 
while (not EMPTY(L)) loop 
DELETE(L); 
end loop; 
end if; 

FREEJ_IST(L); 
end DISPOSE; 

end GENERIC_LI ST ; 
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TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE ORDERED_GENERIC_LI ST 

-- FILE NAME: ORDLIST . ADA 



-- OATE CREATED: 18 APR 88 

-- LAST MODIFIED: 28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package defines the operations 

available on the abstract data type LIST. 



generic 

type ITEM_TYPE is private; 
package ORDERED_GENERIC_LIST is 

type LIST is limited private; 

LIST_OVERFLOW : exception; 

LISTUNDERFLOW : exception; 

-- Operations: If the list is not empty, then one of the nodes is designated 

as the current node. Ocaasional ly , in the postcondition, it is necessary 
to refer to the list of the current node as they were immediately before 
execution of the operation. L-pre and c-pre, respectively, are employed 
for these references. 

procedure FIND_FIRST(L : in out LIST) ; 

— pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure FIND_NEXT(L : in out LIST); 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNOERFLOW if L is empty. 

- LIST_OVERFLOW if the last node is the current node. 

procedure FIN0_PREVI0US( L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNOERFLOW if L is empty or c is the first node. 

procedure F IND_LAST ( L : in out LIST); 

-- pre - The list L is not empty. 



251 



-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

procedure RETRIEVED : in LIST; ITEM : out ITEM_TYPE ) ; 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFL0W if L is empty. 



procedure UPDATE(L : 
-- pre - The list L 
-- post - The current 
-- exceptions raised 



in out LIST ; ITEM ; 
is not empty, 
node in L contains 
- LIST_UNDERFL0W if 



in I TEM_TYPE ) ; 

ITEM as its element 
L is empty. 



procedure INSERT( L : in out LIST; ITEM : in ITEM_TYPE ; KEY : in positive); 
-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is in the list in ascending order 

specified by KEY. The node containing ITEM is the current node. 
-- exceptions raised - LIST_0VERFL0W if L has reached its bound. 



procedure DELETE( L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

function SIZE_0F{L ; in LIST) return natural; 

-- post - SIZEOF is the number of nodes in list L. 



function EMPTY(L ; in LIST) return boolean; 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 



function FULL(L : in LIST) return boolean; 

-- post - If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 



function FIRST ( L : in LIST 
-- pre - The list L is not 
-- post - If the first node 
FIRST is false. 

-- exceptions raised - LIST 



) return boolean; 
empty . 

is the current node in L then FIRST is true, else 
JJNDERFLOW if L is empty. 



function LAST ( L : in LIST) return boolean; 

-- pre - The list L is not empty. 

- post - If the last node is the current node in L then LAST is true, else 
LAS! is false. 

-- exceptions raised - LISTUNDERFLOW if L is empty. 
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procedure CREATE(L : in out LIST; SUCCESS : out boolean); 

-- post - If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

procedure DISPOSE(L : in out LIST); 

-- post - L-pre does not exist. 

private 

type LIST_INSTANCE ; 

type LIST is access LIST_INSTANCE ; 

end ORDERED_GENERIC_LlST; 

with UNCHECKED_DEALLOCATION; 
package body ORDERED_GENERIC_LIST is 

type NODE; 

type NODE_POINTER is access NODE; 
type NODE is 
record 

KEY : positive; 

ELEMENT : ITEM_TYPE ; 

NEXT : NODE_POINTER ; 
end record; 
type LIST_INSTANCE is 
record 

HEAD : NODE_POI NTER := null; 

TAIL : NODE_POINTER := null ; 

CURRENT : NODE_POINTER ;= null; 

SIZE : natural := 0; 
end record; 

procedure FREENODE is new UNCHECKED_DEALLOCATION( NODE , N0DE_P0INTER) ; 
procedure FREE_LIST is new UNCHECKED_DEALL0CATI0N( LISTINSTANCE , LIST); 

procedure FIND_FIRST(L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFL0W if L is empty, 
begin 

if ( EMPTY ( L ) ) then 

raise LISTJJNDERFLOW; 
end if; 

L. CURRENT := L .HEAD; 
end FIND_FIRST ; 

procedure FIND_NEXT(L : in out LIST) is 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

- exceptions raised - LIST UNDERFLOW if L is empty. 
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- LIST JJVERF LOW if the last node is the current node. 

beg i n 

if (EMPTY(L) ) then 

raise LI STUNDERFLOW ; 
end if; 

if ( LAST ( L ) ) then 
raise LIST JJVERF LOW; 
end if; 

L. CURRENT := L . CURRENT . NE X T ; 
end FIND_NEXT; 

procedure F IND_PREVIOUS( L : in out LIST) is 

-- pre - The list L is not empty and the first node is not the current node. 

-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 

TEMP_POINTER ; NODE_POINTER ; 

begin 

if (EMPTY(L) or FIRST(L) ) then 
raise LIST_UNDERFLOW; 
end if; 

TEMP_POINTER := L .HEAD; 

while ( TEMP_PO INTER .NEXT /= L. CURRENT) loop 
TEMP_POINTER := TEMP_POINTER .NEXT ; 
end loop; 

L. CURRENT := TEMP_POINTER ; 
end FIND_PREVIOUS; 

procedure FIND_LAST ( L : in out LIST) is 
-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LISTJJNDERFLOW if L is empty, 
begi n 

if (EMPTY(L)) then 

raise LISTJJNDERFLOW; 
end if; 

while (not LAST(L)) loop 
FIND_NEXT(L) ; 
end loop; 
end FIND_LAST ; 

procedure RETRI EVE( L ; in LIST; ITEM : out ITEM_TYPE ) is 
-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 

- exceptions raised - LISTJJNDERFLOW if L is empty, 
begi n 

if ( EMPTY ( L ) ) then 

raise LISTJJNDERFLOW ; 
end if; 

ITEM := L. CURRENT. ELEMENT; 
end RETRIEVE; 
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procedure UPDATE ( L : in out LIST; ITEM ; in I TEM_TYPE ) is 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
beg 1 n 

if (EMPTY(L)) then 
raise LI ST_UNDERFLOW ; 
end if; 

L. CURRENT. ELEMENT := ITEM; 
end UPDATE; 

procedure INSERT(L : in out LIST; ITEM : in ITEM_TYPE ; KEY : in positive) is 
-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is in the list in ascending order 

specified by KEY. The node containing ITEM is the current node. 

-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 

TEMP_POI NTER : N0DE_P0I NTE R ; 

SEARCH_POINTER : NODE_POI NTE R ; 
beg in 

if (FULL(L)) then 
raise LISTJJVERFLOW ; 
end if; 

TEMP_P0INTER ;= new NODE ’( KEY , ITEM, null); 
if ( L .HE AD = null ) then 
L .HEAD := TEMP_POINTER ; 

L.TAIL := TEMP_POI NTER ; 
el se 

if (L. HEAD. KEY > KEY) then 
TEMP_POI NTE R .NEXT := L . HEAD ; 

L .HEAD := TEMPPOINTER; 
else 

SEARCH_POI NTER ;= L. HEAD. NEXT; 
if ( SEARCH_P0INTER /= null) then 
if ( SEARCH_POI NTER . KEY > KEY) then 
TEMPPOINTER .NEXT := SEARCHPOINTER ; 

L. HEAD. NEXT := TEMP_POI NTER ; 
el se 

while ( (SEARCHPOINTER .NEXT /= null) and then 
(SEARCH_P0INTER. NEXT. KEY < KEY)) loop 
SEARCH_POINTER := SEARCH_POI NTER .NEXT; 
end loop; 

TEMP_POINTER .NEXT := SEARCH_POINTER .NEXT ; 

SEARCHPOI NTER .NEXT ;= TEMP POINTER; 
if (SEARCH_POINTER = L.TAIL) then 
L.TAIL ;= TEMP_POINTER; 
end if; 
end i f ; 
else 

L. HEAD. NEXT := TEMPPOI NTE R ; 

L.TAIL := TEMPPOINTER; 
end if; 
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end if; 
end if; 

L. CURRENT ;= TEMPPOINTER ; 
L . SIZE := L.SIZE + 1; 
end INSERT; 



procedure DELETE(L ; in out LIST) is 
-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

then c-next, if it exists, is the successor of c-prior. If the 
list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFL0W if L is empty. 

TEMP_POINTER : NODE_POINTER ; 
begin 

if ( EMPTY ( L ) ) then 
raise LISTJJNDERFLOW; 
end if; 

if (L. CURRENT /= L .HEAD ) then 
TEMP_POINTER := L . HEAD ; 

while ( TEMPPOINTER .NEXT /= L. CURRENT) loop 
TEMP_POINTER := TEMP_POINTER . NEXT ; 
end loop; 

TEMP_POINTER .NEXT := L .CURRENT . NEXT ; 
if (L. CURRENT = L.TAIL) then 
L . TAIL := TEMP_POINTER ; 
end if; 
else 

if ( L . HEAD = L.TAIL) then 
L.TAIL := null; 
end if; 

L .HEAD ;= L. HEAD. NEXT; 
end if; 

FREE_NODE(L. CURRENT); 

L. CURRENT := L.TAIL; 

L.SIZE := L.SIZE - 1; 
end DELETE; 



function SIZE_OF(L ; in LIST) return natural is 
-- post - SIZE_OF is the number of nodes in list L. 
begin 

return (L.SIZE); 
end SI ZE_OF ; 

function EMPTY(L ; in LIST) return boolean is 

-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
false. 

begin 

return (L.HEAD = null); 
end EMPTY; 
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the maximum 



function FULL(L : in LIST) return boolean is 
-- post - If the number of nodes in the list L has reached 
allowed, then FULL is true, else FULL is false. 
TEMP_POINTER : NODEPOI NTER ; 
begin 

TEMP_POINTER := new NODE; 

FREE_NODE(TEMP_POlNTER); 
return (FALSE); 
exception 

when STORAGE_ERROR => 
return (TRUE); 
when others => 
raise; 



end FULL; 






function 


FIRST ( L : in LIST ; 


) return boolean is 


-- pre 


The list L is not 


empty . 


-- post - 


If the first node 


is the current node in L then FIRST 


-- 


FIRST is false. 




-- exceptions raised - LIST 


UNDERFLOW if L is empty. 



beg i n 

if ( EMPTY ( L ) ) then 

raise LISTJJNDERFLOW; 
end if; 

return (L. CURRENT = L .HEAD) ; 
end FIRST; 

function LAST(L ; in LIST) return boolean is 
-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is 
LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty, 
begin 

if ( EMPTY ( L ) ) then 

raise LISTJJNDERFLOW; 
end if; 

return (L. CURRENT = L . TAIL ) ; 
end LAST ; 

procedure CREATE ( L ; in out LIST; SUCCESS : out boolean) is 

-- post - If a list L can be created then L exists and is empty, 
is TRUE else SUCCESS is FALSE. 

begin 

L := new L IST_INSTANCE '(null , null, null, 0); 

SUCCESS := TRUE; 
exception 

when STORAGE_ERROR => 

SUCCESS := FALSE; 
when others => 
raise; 
end CREATE; 



is true, else 



true, else 



and SUCCESS 
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procedure DISPOSE(L : in 
-- post - L-pre does not 
begin 

if (not EMPTY ( L ) ) then 
F I NO LAST ( L ) ; 
while (not EMPTY ( L ) ) 
OELETE(L) ; 
end loop; 

end if; 

FREE_L IST( L ) ; 
end DISPOSE ; 

end OROERED_GENERIC_LIST; 



out LIST) is 
exist. 



loop 
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TITLE: 



ADAFLOW 



-- MODULE NAME: PACKAGE GENERIC_STACK 

-- FILE NAME: STACK. ADA 



-- DATE CREATED: 31 MAR 88 

-- LAST MODIFIED: 28 APR 88 



-- AUTHOR(S): LT ALBERT J. GRECCO, USN 



DESCRIPTION: This package defines the operations 

available on the abstract data type STACK. 



generic 

type ITEMTYPE is private; 
package GENERIC_STACK is 

type STACK is limited private; 

STACK_OVERFLOW : exception; 

STAC K_UNDER FLOW : exception; 

procedure POP(S : in out STACK; ITEM : out ITEM_TYPE ) ; 

-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 

S no longer contains ITEM. 

-- exceptions raised - STACK_UNDERFLOW if S is empty. 

procedure TOP(S : in STACK; ITEM : out ITEMTYPE); 

-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 

-- exceptions raised - STACKUNDERFLOW if S is empty. 

procedure PUSH(S : in out STACK; ITEM : in I TEM_TYPE ) ; 

-- pre - The size of S has not reached its bound. 

-- post - S includes ITEM as its most recently arrived element. 

-- exceptions raised - STACK_OVERFLOW if S has reached its bound. 

function EMPTY(S : in STACK) return boolean; 

-- post - If the stack S has no ITEMS then EMPTY is true, else EMPTY is 
false. 

function FULL(S : in STACK) return boolean; 

- post - If the number of ITEMS in the stack S has reached the maximum 
allowed, then FULL is true, else FULL is false. 
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procedure CREATE(S . in out STACK; SUCCESS : out boolean); 

-- post - If a stack S can be created then S exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

procedure DISPOSE(S : in out STACK); 

-- post - S-pre does not exist. 

private 

type NODE; 

type STACK is access NODE; 

end GENERIC_STACK; 

with UNCHECKED_DEALLOCATION; 
package body GENERIC_STACK is 

type NODE is 
record 

ELEMENT : I TEMTYPE ; 

NEXT : STACK; 
end record; 

procedure FREE_NODE is new UNC NEC KED_DE ALLOC AT ION ( NODE , STACK); 

procedure POP(S : in out STACK; ITEM : out ITEM_TYPE) is 
-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 

S no longer contains ITEM. 

-- exceptions raised - STACK_UNDERFLOW if S is empty. 

TEMPPOINTER : STACK; 
begin 

if (EMPTY(S)) then 

raise STAC K_UNDER FLOW; 
end if; 

ITEM := S. ELEMENT; 

TEMP_POINTER := S; 

S := S . NEXT ; 

FREE_NODE( TEMP_POINTER ) ; 
end POP; 

procedure TOP(S : in STACK; ITEM : out I TEM_TYPE ) is 
-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 

- exceptions raised - STACK_UNDERFLOW if S is empty, 
beg in 

if ( EMPTY ( S ) ) then 

raise STACKUNDERFLOW; 
end if; 

ITEM := S. ELEMENT; 
end TOP; 
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procedure PUSH(S : in out STACK; ITEM : in I TEM_TYPE ) is 
-- pre - The size of S has not reached its bound. 

-- post - S includes ITEM as its most recently arrived element. 

-- exceptions raised - STACK_0VERFL0W if S has reached its bound. 

TEMPPOINTER : STACK; 
beg in 

if (FULL(S)) then 

raise STACK_OVERFLOW; 
end if; 

TEMP_POINTER := new N0DE'(IT£M, S); 

S := TEMPPOINTER; 
end PUSH; 

function EMPTY(S : in STACK) return boolean is 

-- post - If the stack S has no ITEMS then EMPTY is true, else EMPTY is 
false. 

begin 

return ( S = null); 
end EMPTY; 

function FULL(S : in STACK) return boolean is 

-- post - If the number of ITEMS in the stack S has reached the maximum 
allowed, then FULL is true, else FULL is false. 

TEMP POINTER : STACK; 
begin 

TEMP_POINTER := new NODE; 

FREE_N0DE( TEMP_PO INTER ) ; 
return (FALSE); 
exception 

when ST0RAGE_ERR0R => 
return (TRUE); 
when others => 
raise ; 
end FULL; 

procedure CREATE(S ; in out STACK; SUCCESS : out boolean) is 
-- post - If a stack S can be created then S exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 

begin 

S := null; 

SUCCESS := TRUE; 
end CREATE; 

procedure DISPOSE(S : in out STACK) is 
-- post - S-pre does not exist. 

TEMP_POINTER : STACK; 
begin 

while (S /= nul 1 ) loop 
TEMP_POINTER S; 

S ;= S . NEXT ; 

FREE_NODE( TEMP POINTER); 
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end loop; 
end DISPOSE; 



nd GENERIC_STACK 
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